• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Add coloured row at data change

E

Emeng

Member
Hi all

I wish to add a row when data changes in column 13 and colour it red (255), see code below. Any/all hints & help appreciated.


Regards Mark

[pre]
Code: 
Sub SubtotalAndFormat()
' SubtotalAndFormat Macro

Dim aCell As Range, bCell As Range
Dim ExitLoop As Boolean
Dim iRow As Integer
Range("a1").Select
iRow = 2

Columns("B:B").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Mechanical").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mechanical").Sort.SortFields.Add Key:=Range("B1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Mechanical").Sort
.SetRange Range("A1:P99646")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("M:M").Select
ActiveWorkbook.Worksheets("Mechanical").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mechanical").Sort.SortFields.Add Key:=Range("M1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Mechanical").Sort
.SetRange Range("A1:P99646")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").Select
ActiveWorkbook.Worksheets("Mechanical").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mechanical").Sort.SortFields.Add Key:=Range("A1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Mechanical").Sort
.SetRange Range("A1:P99646")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

With Sheets("Mechanical")
.Columns("A:P").Subtotal GroupBy:=13, Function:=xlCount, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

Set aCell = .Cells.Find(What:=" Count", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)

If Not aCell Is Nothing Then
Set bCell = aCell
.Rows(aCell.Row).ClearContents
Do While ExitLoop = False
Set aCell = .Cells.FindNext(After:=aCell)

If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
.Rows(aCell.Row).ClearContents
Else
ExitLoop = True
End If
Loop
End If

.Cells.RemoveSubtotal
End With
End Sub

Sub Colour_Row()
'
' Colour_Row Macro
'

'
Range("A35:P35").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End Sub
[/pre]
 
Hi Emeng


I have run through your code completely aside from your question. I don't know the structure of your file but I can help with your coding. It looks like you are sorting Cols A, B & M then adding subtotals purely for the purpose of adding a line to every second row as you are deleting the subtotals after this happens. If I could see your dataset this would be easier. So I have made my own File : ) : ) : )


I am clueless as to why you would sort these rows independent of one another. Whenever you post an XL question on a forum it is very helpful to post a file with raw data and importantly showing the final result.


The following is my take on your problem without the Red line part as I can't make out what the trigger for that is. Note the way Sorts can be applied.

[pre]
Code: 
Option Explicit

Sub SortMe()
Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Sort [b2], 1
Range("M2:M" & Cells(Rows.Count, 13).End(xlUp).Row).Sort [M2], 1
Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Sort [a2], 1

'This is the Part that Adds a row (note No Loop)
Range("M2:M" & Cells(Rows.Count, 13).End(xlUp).Row).Offset(, 1).Formula = "=row()-1"
Range("N2:N" & Cells(Rows.Count, 13).End(xlUp).Row).Copy
Range("N" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
Range("A2:N" & Cells(Rows.Count, 14).End(xlUp).Row).Sort [N2], 1
End Sub
[/pre]

Here is a file to show workings.


http://rapidshare.com/files/3033010596/AddRowEvery2nd.xlsm


Take care


Smallman
 
Emeng


When you say you want to add a row when a value changes in Column M

Do you want to add it directly after the row where the value changes or at the end of the data area?


If you want it automatically to happen why not have this code in a Worksheet_Change event that will look at every change in the worksheet and run it automatically


As Smallman said, If you can post a file, that would be a lot more help

http://chandoo.org/forums/topic/posting-a-sample-workbook
 
Hi guys, thanks for your interest.

I have uploaded excel and word docs to explain where I would like to go with this macro. Any help much appreciated.


Smallman, thanks for your spreadsheet but no cigar.


http://rapidshare.com/files/61367963/Sub%20Format%20Plan.xlsm

http://rapidshare.com/files/4251950509/Sub%20Format%20Plan.docx


Regards Mark
 
Emeng


What part of this;


"Smallman, thanks for your spreadsheet but no cigar"


is not Ok. If you open that file it does everything your code does. Goes like thunder!!! You need to be a bit more specific. Also always post a workbook with your question. Takes the guesswork out of it for people at the other end.


Take care


Smallman
 
Hi Smallman

It works a treat, but does not do what I am trying to achieve.

I need to sort three workgroups into start times on different days (day/group/time), with a row between each group and between each day; coloured if possible.

This is step 3 or 4 of 8. The uploaded notes outline where I would like to go with the spreadsheet, also attached.

This is a first attempt at VBA and uploading code was as much a mystery as the program language remains.

Hats off to you and others, for the generous help and encouragement given to plodders like me.

Regards

Mark
 
Hi Mark


Thanks for your kind words. We must have posted at the same time or I just missed your files above - sorry if that is the case. Will have a look at it tonight when I can access the files.


Take care


Smallman
 
Hi Mark


I enjoyed reading your Word document. Very honest! I like it.


Your 86 lines in the process called B_ExportToMechanicalAndFormat can be shortened to;

[pre]
Code: 
Option Explicit
Sub Regig()
Const s = "Mechanical"

Sheet4.[D5:D1000].AutoFilter 1, "<>Object", xlAnd, "<>"
Sheet4.[A5:P1000].Copy Sheets("Mechanical").[A1]
Sheets(s).Range("A2", Sheets(s).Range("P65536").End(xlUp)).Sort Sheets(s).[M1], 1
Sheets(s).Range("A:P").EntireColumn.AutoFit
End Sub

It will produce identical results!!!!


The procedure titled A_CreateWorksheets can be enhanced to do the things you wish with the following.


Option Base 1
Sub A_CreateWorksheets()
Dim ar As Variant
Dim arr As Variant
Dim i As Integer

arr = Sheet4.Range("A5:P5")
ar = Array("Electrical", "Operations", "RPMS", "Cranes & EWPs", "Contractors", "SupportServices", "Mechanical")

For i = 1 To UBound(ar)
If ar(i) <> "Mechanical" Then
Worksheets.Add(After:=Worksheets(i)).Name = ar(i)
[a1:p1] = arr
Else
Worksheets.Add(, Worksheets(1)).Name = ar(i)
End If
Next i
End Sub
[/pre]
Onto Part C and Ron De Bruin's code. Now that I could really cut deeply into. But go away for now and have a play with the above. It should sort you out. Let the group know how you are travelling - keep in mind this forum is going off line for 3 days as of tomorrow.


One thing to remember when working with the .cells is that you are working with all of the cells. So do this before you run any of the above. Go to the Integrated Plan Sheet - Go View - Normal. Now delete all rows from 602 to end of worksheet. SAVE the workbook. This will speed your spreadsheet up as there are lots of unused cells in your file due to your earlier procedures.


Hopefully hear from you shortly.


Take it easy


Smallman
 
Hi Smallman


I ran your codes over the weekend and they work a charm.

I have other spreadsheets which need similar treatment, same same but different, and am adapting the codes to suit. Love your work.

Regards

Mark
 
You must log in or register to reply here.
Back
Top