Macro not responding

[TERRI LEE]

Option Explicit

Sub Driver_Analysis()
Dim i As Long, lrow As Long, j As Long, lastrow As Long

Application.ScreenUpdating = False

If Not Evaluate("ISREF(Driver_Analysis!A1)") Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Driver_Analysis"
Else
    Worksheets("Driver_Analysis").Delete
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Driver_Analysis"
End If

Worksheets("Driver_Analysis").Range("A4:K4") = Split("Date,Trucks,Weather Conditions,Driver,KM,Diesel Req No,Diesel Filled (Litres), Diesel Consumption, Trip Sheet, Weighbridge Ticket, Tons", ",")
Worksheets("Driver_Analysis").Rows(4).Font.Bold = True

For i = 1 To Worksheets.Count
    With Worksheets(i)
        If Len(.Name) <= 2 Then
            lrow = .Range("D" & .Rows.Count).End(xlUp).Row
            For j = 7 To lrow
                If .Range("A" & j).Value <> "" Then
                    lastrow = Worksheets("Driver_Analysis").Range("A" & Rows.Count).End(xlUp).Row
                    .Range("A" & j & ":C" & j).Copy
                    Worksheets("Driver_Analysis").Range("A" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    .Range("E" & j).Copy
                    Worksheets("Driver_Analysis").Range("D" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    .Range("H" & j & ":K" & j).Copy
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteComments)
                    .Range("M" & j & ":N" & j).Copy
                    Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteComments)
                     .Range("Y" & j).Copy
                    Worksheets("Driver_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If
            Next j
        End If
    End With
Next i

With Worksheets("Driver_Analysis")
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    .Sort.SortFields.Add Key:=Range("D5:D" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With .Sort
        .SetRange Range("A4:K" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    .Range("A4:K" & lrow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 7), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    lrow = .Range("D" & .Rows.Count).End(xlUp).Row
    
    For i = 5 To lrow
        If .Range("D" & i).Value Like "*Total" And .Range("D" & i).Value <> "Grand Total" Then
            .Range("H" & i).Value = .Range("E" & i).Value / .Range("G" & i).Value
        ElseIf .Range("C" & i).Value = "Grand Total" Then
            .Rows(i).Font.Bold = True
            .Rows(i).Font.Color = -16776961
            .Range("H" & i).Value = .Range("E" & i).Value / .Range("G" & i).Value
        End If
    Next i
    
    .Cells.EntireColumn.AutoFit
        
    With .Range("A4:K" & lrow)
        .Font.Size = 8
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        With .Borders()
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
    
End With

Application.ScreenUpdating = True

End Sub

Option Explicit
Sub Truck_Analysis()
Dim i As Long, lrow As Long, j As Long, lastrow As Long
Dim mycmt As Variant

Application.ScreenUpdating = False

If Not Evaluate("ISREF(Truck_Analysis!A1)") Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Truck_Analysis"
Else
    Worksheets("Truck_Analysis").Delete
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Truck_Analysis"
End If

Worksheets("Truck_Analysis").Range("A1:K1") = Split("Date,Trucks,Weather Conditions,Driver,KM,Diesel Req No,Diesel Filled (l), Diesel Consumption, Trip Sheet, Weighbridge Ticket, Tons", ",")
Worksheets("Truck_Analysis").Rows(1).Font.Bold = True

For i = 1 To Worksheets.Count
    With Worksheets(i)
        If Len(.Name) <= 2 Then
            lrow = .Range("D" & .Rows.Count).End(xlUp).Row
            For j = 7 To lrow
                If .Range("A" & j).Value <> "" Then
                    lastrow = Worksheets("Truck_Analysis").Range("A" & Rows.Count).End(xlUp).Row
                    .Range("A" & j & ":C" & j).Copy
                    Worksheets("Truck_Analysis").Range("A" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("A" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("A" & lastrow + 1).PasteSpecial (xlPasteComments)
                    .Range("E" & j).Copy
                    Worksheets("Truck_Analysis").Range("D" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("D" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("D" & lastrow + 1).PasteSpecial (xlPasteComments)
                    .Range("H" & j & ":K" & j).Copy
                    Worksheets("Truck_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteComments)
                    .Range("M" & j & ":N" & j).Copy
                    Worksheets("Truck_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteComments)
                     .Range("Y" & j).Copy
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteComments)
                End If
            Next j
        End If
    End With
Next i

With Worksheets("Truck_Analysis")
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    .Sort.SortFields.Add Key:=Range("B1:B" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With .Sort
        .SetRange Range("A1:K" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    .Range("A1:K" & lrow).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 7), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    lrow = .Range("B" & .Rows.Count).End(xlUp).Row
    
    For i = 5 To lrow
        If .Range("B" & i).Value Like "*Total" And .Range("B" & i).Value <> "Grand Total" Then
            .Range("H" & i).FormulaR1C1 = "=IF(RC[-1]="""","""",RC[-3]/RC[-1])"
        ElseIf .Range("C" & i).Value = "Grand Total" Then
            .Rows(i).Font.Bold = True
            .Rows(i).Font.Color = -16776961
            .Range("H" & i).FormulaR1C1 = "=IF(RC[-1]="""","""",RC[-3]/RC[-1])"
        End If
    Next i
    
    .Cells.EntireColumn.AutoFit
        
    With .Range("A1:K" & lrow)
        .Font.Size = 8
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        With .Borders()
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
    
End With

Application.ScreenUpdating = True

End Sub

Hi can anyone help me with these codes. For some reason they are now taking forever to run. I am not sure it even finishes because i cancel after about 45minutes.

Thanks

[arlu1201]

Are there many formulae in your file? If yes, then add this statement

Application.Calculation = xlCalculationManual

after your last Dim statement in each code. And add this statement

Application.Calculation = xlCalculationAutomatic

before the End Sub.

Also it tends to happen that the files get corrupted after repeated use. So you can copy the contents to a new file, add in all the macros and see if the problem persists.

[TERRI LEE]

Hi Arlu

I suspected it was corrupt because I had alot of computer issues this past week so I already tried to copy everything to a new file. Funny thing is that the macros would not run in workbooks that they previously did run in. I will try your suggestions now.

I just want to clarify the below:

I wanted to copy formula results from my initial sheets to the sheet that the macro makes. The two macros above are supposed to do this but I suspect I have done something incorrect here. On the one sheet when it did manage to run the macro it copied the formating for protecting the certain cells. i wanted it only to copy the formating that resulted in the red cells.

Perhaps instead of me coping the formating from the origanal sheets I should set the formating up within the macro so that it runs it on the macro generated sheet. (I would need help with this as I would not know where to start)

What do you think?

Terri

[RHCPgergo]

You are making a lot of copying, that's why it's slow. Try to copy whole columns instead of single rows one by one. Or instead of copying, just get the value.

[arlu1201]

Also, you can empty your clipboard by doing this

For the 1st code, replace

 .Range("Y" & j).Copy
                    Worksheets("Driver_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If

with

 .Range("Y" & j).Copy
                    Worksheets("Driver_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Application.cutcopymode = False
                End If

For the 2nd code - replace

.Range("Y" & j).Copy
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteComments)
                End If

with

.Range("Y" & j).Copy
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteFormats)
                    Worksheets("Truck_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteComments)
                    Application.cutcopymode = false
                End If

[arlu1201]

You can try the changes i suggested. If it still gives you issues, we can re-work the formatting code part.

[TERRI LEE]

Should i try to make all the changes at once or first post two and then post 4. I have tried to do just post one and after ten minutes it is still not complete.

[arlu1201]

Try one code at a time. Change the entire code as per what i suggested.

[TERRI LEE]

When I terminate it it always debugs highlighting the following:

Range("A4:K" & lrow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 7), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

[TERRI LEE]

Hi

I tried both and sadly they are still not working.

[RHCPgergo]

@ TERRI LEE #10:
try to exclude that line and see what happens when running the code. Maybe that's what causing the main problem.

[arlu1201]

The code in post 10 is needed as she needed subtotals to be inserted in the file.

[RHCPgergo]

The code in post 10 is needed as she needed subtotals to be inserted in the file.

Okay, but first let's identify the problem and see what's causing the macro to be so slow. (I might have been wrong in post #3 that the copying took so long.)

After that we can move on to find an alternative code for the slow part. At least that's the logic I'm trying to follow.

[TERRI LEE]

How do i fix this

[TERRI LEE]

The macros ran fine until we added the lines coping the formats. If I take these out it runs fine.

[RHCPgergo]

In that case I suggest using the old macro and add some formatting code at the end.

[TERRI LEE]

Thats great but I am new to macros and what I have tried thus far has not worked.

[RHCPgergo]

If you attach a sample workbook that shows how it should look like, I can help you with it.

[TERRI LEE]

Option Explicit

Sub Driver_Test()
Dim i As Long, lrow As Long, j As Long, lastrow As Long
  
Application.ScreenUpdating = False

If Not Evaluate("ISREF(Driver_Analysis!A1)") Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Driver_Analysis"
Else
    Worksheets("Driver_Analysis").Delete
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Driver_Analysis"
End If

Worksheets("Driver_Analysis").Range("A4:K4") = Split("Date,Trucks,Weather Conditions,Driver,KM,Diesel Req No,Diesel Filled (Litres), Diesel Consumption, Trip Sheet, Weighbridge Ticket, Tons", ",")
Worksheets("Driver_Analysis").Rows(4).Font.Bold = True

For i = 1 To Worksheets.Count
    With Worksheets(i)
        If Len(.Name) <= 2 Then
            lrow = .Range("D" & .Rows.Count).End(xlUp).Row
            For j = 7 To lrow
                If .Range("A" & j).Value <> "" Then
                    lastrow = Worksheets("Driver_Analysis").Range("A" & Rows.Count).End(xlUp).Row
                    .Range("A" & j & ":C" & j).Copy
                    Worksheets("Driver_Analysis").Range("A" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    .Range("E" & j).Copy
                    Worksheets("Driver_Analysis").Range("D" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    .Range("H" & j & ":K" & j).Copy
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteComments)
                    .Range("M" & j & ":N" & j).Copy
                    Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                     Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteComments)
                      .Range("Y" & j).Copy
                    Worksheets("Driver_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If
            Next j
        End If
    End With
Next i

With Worksheets("Driver_Analysis")
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    .Sort.SortFields.Add Key:=Range("D5:D" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With .Sort
        .SetRange Range("A4:K" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    .Range("A4:K" & lrow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 7), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    lrow = .Range("D" & .Rows.Count).End(xlUp).Row
    
    For i = 5 To lrow
        If .Range("D" & i).Value Like "*Total" And .Range("D" & i).Value <> "Grand Total" Then
            .Range("H" & i).Value = .Range("E" & i).Value / .Range("G" & i).Value
        ElseIf .Range("C" & i).Value = "Grand Total" Then
            .Rows(i).Font.Bold = True
            .Rows(i).Font.Color = -16776961
            .Range("H" & i).Value = .Range("E" & i).Value / .Range("G" & i).Value
        End If
    Next i
    
    .Cells.EntireColumn.AutoFit
        
    With .Range("A4:K" & lrow)
        .Font.Size = 8
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        With .Borders()
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
    lrow = Range("E" & Rows.Count).End(xlUp).Row
    Range("E5:E" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(G5>0,E5<=0)"
    With Range("E5:E" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
   lrow = Range("G" & Rows.Count).End(xlUp).Row
    Range("G5:G" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(E5>0,G5<=0)"
    With Range("G5:G" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
    lrow = Range("H" & Rows.Count).End(xlUp).Row
    Range("H5:H" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="cellvalue=>2.05"
    With Range("H5:H" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
    lrow = Range("C" & Rows.Count).End(xlUp).Row
    Range("C5:C" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(C5>="" "",B5="" "")"
    With Range("C5:C" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
End With

Application.ScreenUpdating = True

End Sub

Hi this is what I have come up with. I need help with the following sections please:

 lrow = Range("H" & Rows.Count).End(xlUp).Row
    Range("H5:H" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="cellvalue=>2.05"
    With Range("H5:H" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic

I wanted this to fill the cell in row H with the color red if it is equal to or less than 2.05

lrow = Range("C" & Rows.Count).End(xlUp).Row
    Range("C5:C" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(C5>="" "",B5="" "")"
    With Range("C5:C" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255

Here i wanted a red fill in the cell if there is no text in cells in column C ( it should exclude the subtotal and total rows)

In actual fact all 4 conditional formatings in the macros should exclude the subtotals and totals rows.

[RHCPgergo]

What arlu said, or you can use this code:

Dim Rng As Range
lrow = Range("D" & Rows.Count).End(xlUp).Row
For Each Rng In Range("D5:D" & lrow)
    If Right(LCase(Rng.Text), 5) <> "total" Then
        '1: if E<=0 and G>0 then E is red
        If Rng.Offset(0, 1).Value <= 0 And Rng.Offset(0, 3).Value > 0 Then _
            Rng.Offset(0, 1).Interior.Color = 255
        '2: if E>0 and G<=0 then G is red
        If Rng.Offset(0, 1).Value > 0 And Rng.Offset(0, 3).Value <= 0 Then _
            Rng.Offset(0, 3).Interior.Color = 255
        '3: if H<=2.05 then H is red
        If Rng.Offset(0, 4).Value <= 2.05 Then _
            Rng.Offset(0, 4).Interior.Color = 255
        '4: if C is empty then C is red
        If Rng.Offset(0, -1).Value = "" Then _
            Rng.Offset(0, -1).Interior.Color = 255
    End If
Next Rng

instead of this part

    lrow = Range("E" & Rows.Count).End(xlUp).Row
    Range("E5:E" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(G5>0,E5<=0)"
    With Range("E5:E" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
   lrow = Range("G" & Rows.Count).End(xlUp).Row
    Range("G5:G" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(E5>0,G5<=0)"
    With Range("G5:G" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
    lrow = Range("H" & Rows.Count).End(xlUp).Row
    Range("H5:H" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="cellvalue=>2.05"
    With Range("H5:H" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With
    lrow = Range("C" & Rows.Count).End(xlUp).Row
    Range("C5:C" & lrow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(C5>="" "",B5="" "")"
    With Range("C5:C" & lrow).FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
    End With

I made some comments to make it clear. Note that the code is not conditional formatting, it's just simple formatting.

[arlu1201]

In that case, you can put the color formats for the rows and then do the subtotals.

[TERRI LEE]

Hi

If I use the code from RHCPgergo where do i insert it into my code. I also needed help as per post 19 with the two corrections that needed to be made.

Terri

[RHCPgergo]

It should look something like this. In the code I already made the two corrections - at least I think that's what you wanted.

Option Explicit

Sub Driver_Test()
Dim i As Long, lrow As Long, j As Long, lastrow As Long
  
Application.ScreenUpdating = False

If Not Evaluate("ISREF(Driver_Analysis!A1)") Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Driver_Analysis"
Else
    Worksheets("Driver_Analysis").Delete
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Driver_Analysis"
End If

Worksheets("Driver_Analysis").Range("A4:K4") = Split("Date,Trucks,Weather Conditions,Driver,KM,Diesel Req No,Diesel Filled (Litres), Diesel Consumption, Trip Sheet, Weighbridge Ticket, Tons", ",")
Worksheets("Driver_Analysis").Rows(4).Font.Bold = True

For i = 1 To Worksheets.Count
    With Worksheets(i)
        If Len(.Name) <= 2 Then
            lrow = .Range("D" & .Rows.Count).End(xlUp).Row
            For j = 7 To lrow
                If .Range("A" & j).Value <> "" Then
                    lastrow = Worksheets("Driver_Analysis").Range("A" & Rows.Count).End(xlUp).Row
                    .Range("A" & j & ":C" & j).Copy
                    Worksheets("Driver_Analysis").Range("A" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    .Range("E" & j).Copy
                    Worksheets("Driver_Analysis").Range("D" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    .Range("H" & j & ":K" & j).Copy
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                    Worksheets("Driver_Analysis").Range("E" & lastrow + 1).PasteSpecial (xlPasteComments)
                    .Range("M" & j & ":N" & j).Copy
                    Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                     Worksheets("Driver_Analysis").Range("I" & lastrow + 1).PasteSpecial (xlPasteComments)
                      .Range("Y" & j).Copy
                    Worksheets("Driver_Analysis").Range("K" & lastrow + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If
            Next j
        End If
    End With
Next i

With Worksheets("Driver_Analysis")
    lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    .Sort.SortFields.Add Key:=Range("D5:D" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With .Sort
        .SetRange Range("A4:K" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    .Range("A4:K" & lrow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 7), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    lrow = .Range("D" & .Rows.Count).End(xlUp).Row
    
    For i = 5 To lrow
        If .Range("D" & i).Value Like "*Total" And .Range("D" & i).Value <> "Grand Total" Then
            .Range("H" & i).Value = .Range("E" & i).Value / .Range("G" & i).Value
        ElseIf .Range("C" & i).Value = "Grand Total" Then
            .Rows(i).Font.Bold = True
            .Rows(i).Font.Color = -16776961
            .Range("H" & i).Value = .Range("E" & i).Value / .Range("G" & i).Value
        End If
    Next i
    
    .Cells.EntireColumn.AutoFit
        
    With .Range("A4:K" & lrow)
        .Font.Size = 8
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        With .Borders()
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
 Dim Rng As Range
lrow = Range("D" & Rows.Count).End(xlUp).Row
For Each Rng In Range("D5:D" & lrow)
    If Right(LCase(Rng.Text), 5) <> "total" Then
        '1: if E<=0 and G>0 then E is red
        If Rng.Offset(0, 1).Value <= 0 And Rng.Offset(0, 3).Value > 0 Then _
            Rng.Offset(0, 1).Interior.Color = 255
        '2: if E>0 and G<=0 then G is red
        If Rng.Offset(0, 1).Value > 0 And Rng.Offset(0, 3).Value <= 0 Then _
            Rng.Offset(0, 3).Interior.Color = 255
        '3: if H<=2.05 then H is red
        If Rng.Offset(0, 4).Value <= 2.05 Then _
            Rng.Offset(0, 4).Interior.Color = 255
        '4: if C is empty then C is red
        If Rng.Offset(0, -1).Value = "" Then _
            Rng.Offset(0, -1).Interior.Color = 255
    End If
Next Rng
End With

Application.ScreenUpdating = True

End Sub

[TERRI LEE]

Hi

If I want to insert your changes in the macro to run before the subtotals etc where would I insert it?

[RHCPgergo]

Hi

If I want to insert your changes in the macro to run before the subtotals etc where would I insert it?

Before this line I guess, but why do you want to do that? Doesn't it work the way you want?

    .Range("A4:K" & lrow).Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(5, 7), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True

About the meaning of this line:

If Rng.Offset(0, 1).Value > 0 And Rng.Offset(0, 3).Value <= 0 Then _
            Rng.Offset(0, 3).Interior.Color = 255

Rng is a range variable. I use it in a loop so it always means the corresponding cell in column D. (D5, then D6, D7, etc.)
Rng.Offset(0,1) means the cell that is one cell right from the Rng cell. (E5, E6, E7, etc.)
Rng.Offset(0,3) means the cell that is three cells right from the Rng cell. (G5, G6, GE7, etc.)
Rng.Offset(0,1).Value means the value of the referenced range/cell.

So all in all it means what I have already written in the comments in the code: if value in column E is greater than zero AND value in column G is smaller or equal to zero then make the color of the cell in column G red.

(You could write the whole thing in one line, like this, the underscore (_) means that it's one line of code.

If Rng.Offset(0, 1).Value > 0 And Rng.Offset(0, 3).Value <= 0 Then Rng.Offset(0, 3).Interior.Color = 255

[TERRI LEE]

If Right(LCase(Rng.Text), 5) <> "total" Then

Sorry to be a pain but I'm still learning. What does this mean.

[RHCPgergo]

If Right(LCase(Rng.Text), 5) <> "total" Then

Sorry to be a pain but I'm still learning. What does this mean.

Rng: this is a range variable in which I store a single cell. (For example A1.)
Rng.Text: the text value of a range/cell. (Let's say the value of the cell is "Profit Total")
LCase(Rng.Text): makes the text lower case. (In the example "profit total")
Right(LCase(Rng.Text), 5) : cuts down the right side of a string, 5 characters (in the example "total")

So the line means: "if the last 5 characters (lowercase) does not equal 'total', then"

[TERRI LEE]

If Rng.Offset(0, 1).Value > 0 And Rng.Offset(0, 3).Value <= 0 Then _
            Rng.Offset(0, 3).Interior.Color = 255

What does this actually mean in laymen terms.

[TERRI LEE]

It does work fine in the driver analysis but in the other macro called truck analysis it seems to highlight the subtotals row in column C. i thi=ought if this was inserted before it runs the subtotals it would fix it.

Thanks once again for your help.

Terri

[TERRI LEE]

Okay thanks now I at least understand what it is saying. I will be able to make the changes for the other macros where I want to insert this info. Thanks a million.

Regards Terri

[RHCPgergo]

Glad I could help.