Macro not completing to end of data

M

MHamid

Active Member
Joined
Jan 31, 2013
Messages
472
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hello,

I have a code below that will find changes in column J and will insert a blank row after the change.
My issue is that when I continue with the rest of the code, it will leave the last row as blank instead of adding a footer with the header and formatting needed.

I have data in columns J to Q. The change in value we are looking at is in column J. Once I change in value is found, the macro should insert a blank row afterwards, then it should add specific border to columns J:P, highlight J:Q a specific color, and finally add the footer title.

For example, this would be the original data in column J:
Apple
Apple
Apple
Banana
Banana
Banana
Banana
Cherry
Cherry
Cherry
Cherry
Cherry
Mango
Mango

The end result should be:
Apple
Apple
Apple
Apple Total
Banana
Banana
Banana
Banana
Banana Total
Cherry
Cherry
Cherry
Cherry
Cherry
Cherry Total
Mango
Mango
Mango Total


However, for some reason I am not getting "Mango Total". What am I missing in my code?

Code: 
Sub Footer()
Dim lr As Long
Dim r2 As Long
Dim r3 As Long
Dim X As Long, LastRow As Long
Const DataCol As String = "J"
Const StartRow = 2
lr = Range("J" & Rows.Count).End(xlUp).Row
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
    'Compare the values in column J and insert footer when values are different
    Application.ScreenUpdating = False
    For X = LastRow To StartRow + 1 Step -1
        If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert
    Next
    Application.ScreenUpdating = True
           
    'Add specific border for footer
    For r2 = 1 To lr
        If Cells(r2, "J") = "" Then
            Range(Cells(r2, "J"), Cells(r2, "P")).Select
                    With Selection
                        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
                        Selection.Borders(xlEdgeTop).LineStyle = xlNone
                        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
                        Selection.Borders(xlEdgeRight).LineStyle = xlNone
                        Selection.Borders(xlInsideVertical).LineStyle = xlNone
                        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                            With Selection.Borders(xlEdgeLeft)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeTop)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeBottom)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeRight)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                        Selection.Borders(xlInsideVertical).LineStyle = xlNone
                        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                    End With
        End If
    Next r2
    
    'Highlight footer
    For r3 = 1 To lr
         If Cells(r3, "J") = "" Then
            Range(Cells(r3, "J"), Cells(r3, "Q")).Select
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorLight2
                        .TintAndShade = 0.799981688894314
                        .PatternTintAndShade = 0
                    End With
        End If
    Next r3
    
    'Add title to footer
    Range("J1:J" & lr).SpecialCells(xlCellTypeBlanks).Select
    Selection.FormulaR1C1 = "=R[-1]C&"" Total"""
    Selection.Font.Bold = True
    Columns("J:J").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

End Sub

Thank you
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Instead of
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row

try this method to find last row:
LastRow = findLastRow("Sheet1", DataCol)
<your ....="" code="">... your code ...

Function findLastRow(Sheetname As String, ColumnName As String) As Integer
Dim lastRow As Integer
Dim r As Range
Dim WS As Worksheet
Set WS = Worksheets(Sheetname)
lastRow = WS.UsedRange.Rows.Count
'*
'* Search backwards till we find a cell that is not empty
'*
Set r = WS.Range(ColumnName).Rows(lastRow)
While IsEmpty(r)
Set r = r.Offset(-1, 0)
Wend
lastRow = r.Row
Set WS = Nothing
findLastRow = lastRow
End Function
Click to expand...
</your>
 
Last edited by a moderator:
Upvote 0
How about
Code: 
Sub Footer()
   Dim lr As Long
   Dim X As Long
   
   lr = Range("J" & Rows.Count).End(xlUp).row
    'Compare the values in column J and insert footer when values are different
   Application.ScreenUpdating = False
   Range("J" & lr + 1).Value = Range("J" & lr).Value
   For X = lr To 3 Step -1
      If Cells(X, 10).Value <> Cells(X - 1, 10) Then
         Rows(X).Insert
         With Range("J" & X)
            .Value = .Offset(-1).Value
            .Font.Bold = True
            .Resize(, 7).Borders.LineStyle = xlNone
            .Resize(, 7).BorderAround xlContinuous, xlThin
            .Resize(, 8).Interior.Color = 15849925
         End With
      End If
   Next X
   Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hello,

Johnny_J - I tried your code but I am getting an error message argument not optional. I added the function to my code and then added the function name to the code itself to call the function. Did I add it correctly in my code?
Code: 
    'Compare the values in column J and insert footer when values are different
    Application.ScreenUpdating = False
    For X = [COLOR=#ff0000]findLastRow[/COLOR] To StartRow + 1 Step -1
        If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Insert
    Next
    Application.ScreenUpdating = True

Fluff - I tested your code and while it did add the last footer, it did not format it like it formatted the others. Also, I need the added rows to also include the word "Total' after the value from column J.


Thank you
 
Last edited:
Upvote 0
Ok, how about
Code: 
Sub Footer()
   Dim lr As Long
   Dim X As Long
   
   lr = Range("J" & Rows.Count).End(xlUp).row
   Application.ScreenUpdating = False
   For X = lr + 1 To 3 Step -1
      If Cells(X, 10).Value <> Cells(X - 1, 10) Then
         Rows(X).Insert
         With Range("J" & X)
            .Value = .Offset(-1).Value & " Total"
            .Font.Bold = True
            .Resize(, 7).Borders.LineStyle = xlNone
            .Resize(, 7).BorderAround xlContinuous, xlThin
            .Resize(, 8).Interior.Color = 15849925
         End With
      End If
   Next X
   Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hello,

Fluff - I tested the code and it works perfectly. Is it possible to add the below code for a "Grand Total" column?

Code: 
Sub GrandTotal()
Dim lr As Long
Dim r4 As Long
Dim r5 As Long
Dim r6 As Long
'Select cell after last row of data in column J
Range("J" & Cells(Rows.Count, "J").End(xlUp).Row + 1).Value = "Grand Total"
'Formatting
lr = Range("J" & Rows.Count).End(xlUp).Row
   
    For r4 = 1 To lr
         If Cells(r4, "J") = "Grand Total" Then
            Range(Cells(r4, "J"), Cells(r4, "Q")).Select
                    With Selection.Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorLight2
                        .TintAndShade = 0.599993896298105
                        .PatternTintAndShade = 0
                    End With
        End If
    Next r4
'Add Border to Grand Total
    For r5 = 1 To lr
        If Cells(r5, "J") = "Grand Total" Then
            Range(Cells(r5, "J"), Cells(r5, "P")).Select
                    With Selection
                        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
                        Selection.Borders(xlEdgeTop).LineStyle = xlNone
                        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
                        Selection.Borders(xlEdgeRight).LineStyle = xlNone
                        Selection.Borders(xlInsideVertical).LineStyle = xlNone
                        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                            With Selection.Borders(xlEdgeLeft)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeTop)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeBottom)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeRight)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                        Selection.Borders(xlInsideVertical).LineStyle = xlNone
                        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                    End With
        
            Range(Cells(r5, "Q"), Cells(r5, "Q")).Select
                    With Selection
                        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
                        Selection.Borders(xlEdgeTop).LineStyle = xlNone
                        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
                        Selection.Borders(xlEdgeRight).LineStyle = xlNone
                        Selection.Borders(xlInsideVertical).LineStyle = xlNone
                        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                            With Selection.Borders(xlEdgeLeft)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeTop)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeBottom)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                            With Selection.Borders(xlEdgeRight)
                                .LineStyle = xlContinuous
                                .ColorIndex = 0
                                .TintAndShade = 0
                                .Weight = xlThin
                            End With
                        Selection.Borders(xlInsideVertical).LineStyle = xlNone
                        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                    End With
        
        End If
    Next r5
'Changing Font for Grand Total
lr = Range("J" & Rows.Count).End(xlUp).Row
   
    For r6 = 1 To lr
         If Cells(r6, "J") = "Grand Total" Then
            Range(Cells(r6, "J"), Cells(r6, "Q")).Select
                With Selection.Font
                    .Name = "Arial"
                    .Size = 8
                    .Strikethrough = False
                    .Superscript = False
                    .Subscript = False
                    .OutlineFont = False
                    .Shadow = False
                    .Bold = True
                    .Underline = xlUnderlineStyleNone
                    .ThemeColor = xlThemeColorLight1
                    .TintAndShade = 0
                    .ThemeFont = xlThemeFontNone
                End With
        End If
    Next r6

End Sub

Thank you
 
Upvote 0
How about
Code: 
Sub Footer()
   Dim lr As Long
   Dim X As Long
   
   lr = Range("J" & Rows.Count).End(xlUp).row
   Application.ScreenUpdating = False
   For X = lr + 1 To 3 Step -1
      If Cells(X, 10).Value <> Cells(X - 1, 10) Then
         Rows(X).Insert
         With Range("J" & X)
            .Value = .Offset(-1).Value & " Total"
            .Font.Bold = True
            .Resize(, 7).Borders.LineStyle = xlNone
            .Resize(, 7).BorderAround xlContinuous, xlThin
            .Resize(, 8).Interior.Color = 15849925
         End With
      End If
   Next X
   With Range("J" & Cells(Rows.Count, "J").End(xlUp).row + 1)
      .Value = "Grand Total"
      With .Resize(, 8)
         .Interior.Color = 14857357
         .Borders.LineStyle = xlNone
         .BorderAround xlContinuous, xlThin
         .Font.Bold = True
      End With
   End With
End Su
 
Upvote 0
Hello,

The updated code works perfectly!!

Thank you
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
formating question
Replies
3
Views
311
Micron
M
L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
584
RoryA
RoryA
P
  • Question Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
369
6StringJazzer
6StringJazzer
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
1K
kerm007
K
J
  • Question Question
Issue with Macros and renaming files
Replies
6
Views
1K
kevin9999
K

Forum statistics

Threads
1,223,898
Messages
6,175,272
Members
452,628
Latest member
dd2

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top