VBA - Format Rows containing word 'Total'

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,255
Office Version
365
Platform
Windows
I'm afraid from that description I am unsure exactly what you have & where or what you want and where.
Can you provide a small set of dummy data to demonstrate & explain in relation to that?
 

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

tlc53

Active Member
Joined
Jul 26, 2018
Messages
365
I'm afraid from that description I am unsure exactly what you have & where or what you want and where.
Can you provide a small set of dummy data to demonstrate & explain in relation to that?
I thought trying to explain it in words was going to be too confusing. Please find set of dummy data attached.

The total descriptions I would like to automatically appear, I have typed in red (although the format will remain the same as bold/grey fill). You will see the descriptions come from cells A21 and A22 depending on the account numbers in cells K21 and K22 (it goes down to row 35). Column K onwards is outside the print setup and is just there to assist with raising the invoice.

Thank you for taking a look and I hope your weekend has got off to a good start :)

https://www.dropbox.com/s/4rpiue1mku8xwv4/Test for Total Descriptions.xlsx?dl=0
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,255
Office Version
365
Platform
Windows
Your subtotal range seems to be moving about a bit so this code assumes that there is nothing below that subtotal range and that there will be a blank row above and a blank column to the right of it, as is the case in your sample file.

You have a named range 'Criteria' that covers the Account numbers that need to be looked up. I have added a corresponding named range 'Category' that covers the same rows as 'Criteria' but in the merged columns A:C.

This code gets the Descriptions you want into the subtotal region by formula & at this stage I have left them as formulas. If you need them replaced by the values then we can do that.

The code includes the previous code to add the borders etc to columns A:J, although I have replaced the AutoFilter with the built-in ability of subtotals to just show the total rows.

See how it goes.

Rich (BB code):
Sub FormatTotals_v3()
  Application.ScreenUpdating = False
  ActiveSheet.Outline.ShowLevels RowLevels:=2
  With Range("K" & Rows.Count).End(xlUp).CurrentRegion
    With .Offset(1).Resize(.Rows.Count - 1, 10).SpecialCells(xlVisible).Rows
      .Font.Bold = True
      .Interior.Color = 12566463
      .BorderAround xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    With Intersect(.Columns(3), .SpecialCells(xlVisible), .SpecialCells(xlBlanks))
      .FormulaR1C1 = "=IF(RC[8]=""Grand Total"",RC[8],INDEX(Category,MATCH(LEFT(RC[8],LEN(RC[8])-6)+0,Criteria,0),1))"
    End With
  End With
  ActiveSheet.Outline.ShowLevels RowLevels:=3
  Application.ScreenUpdating = True
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,255
Office Version
365
Platform
Windows
*A*M*A*Z*I*N*G* :)

I defined the category name and it works perfectly. Just what I wanted.
Really appreciate that. Thank you!!
You are welcome. Thanks for the follow-up. :)
 

tlc53

Active Member
Joined
Jul 26, 2018
Messages
365
You are welcome. Thanks for the follow-up. :)
Hi Peter, sorry, me again :)

I've just been running some tests on my spreadsheet and there's one small thing in relation to this code which isn't looking right.

I would like the narrative to be in the same order as the summary at the top (K21-K35). Currently it jumps around.

Everything else is working great, so I'm nervous to try and add this myself. Are you able to help please?

Code:
Sub ClientNarrative()


    Range("A52").Select
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Sheets("Invoice Data").Columns("A:K").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("K20:K35"), CopyToRange:=Range("A52:K52"), Unique:= _
        False
            Range("A1").Select


If Range("A53") = 0 Then Exit Sub


Application.ScreenUpdating = False
Dim r As Range
Dim cust As Range




Set r = Range("A52:K" & Range("A" & Rows.Count).End(xlUp).Row)
Set cust = Range("K20:K34")




cust.Offset(, 1).Value = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
r.Columns(11).Offset(1, 1).Resize(r.Rows.Count - 1).FormulaR1C1 = "=VLOOKUP(RC[-1],R20C11:R25C12,2,0)"
r.Value = r.Value
Set r = r.Resize(r.Rows.Count, r.Columns.Count + 1)
r.Sort Key1:=[L52], Order1:=xlAscending, Header:=xlYes
r.Columns(12).ClearContents
cust.Offset(, 1).Value = vbNullString
Application.ScreenUpdating = True


Range("A53").Select


    Selection.CurrentRegion.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
        End With
    Selection.Subtotal GroupBy:=11, Function:=xlSum, TotalList:=Array(6, 7, 9) _
        , Replace:=False, PageBreaks:=False, SummaryBelowData:=True
 
 
  Application.ScreenUpdating = False
  ActiveSheet.Outline.ShowLevels RowLevels:=2
  With Range("K" & Rows.Count).End(xlUp).CurrentRegion
    With .Offset(1).Resize(.Rows.Count - 1, 10).SpecialCells(xlVisible).Rows
      .Font.Bold = True
      .Interior.Color = 14277081
      .BorderAround xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    With Intersect(.Columns(3), .SpecialCells(xlVisible), .SpecialCells(xlBlanks))
      .FormulaR1C1 = "=IF(RC[8]=""Grand Total"",RC[8],INDEX(Category,MATCH(LEFT(RC[8],LEN(RC[8])-6)+0,Criteria,0),1))"
    End With
  End With
  ActiveSheet.Outline.ShowLevels RowLevels:=3
  Application.ScreenUpdating = True


            Range("A1").Select
    End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,255
Office Version
365
Platform
Windows
I'm not sure this is what you mean but try adding this code immediately above the following line in your code
Selection.Subtotal GroupBy ....

I have assumed that the Account numbers in K21:K35 have been sorted into ascending order.

Rich (BB code):
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Selection.Columns(Selection.Columns.Count), Order:=xlAscending
With ActiveSheet.Sort
  .SetRange Selection
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
End With
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,255
Office Version
365
Platform
Windows
I have assumed that the Account numbers in K21:K35 have been sorted into ascending order.
I can now see from your other thread (that I have closed) that my assumption was incorrect.

You should be able to use your custom sort order without having to actually create a new custom list (& deleting it later).
This time I have assumed that cells in the range K21:K35 that do not contain valid account numbers do contain the word "Blank" as per your sample file.

Try this instead

Rich (BB code):
Dim sSortOrder As String

sSortOrder = Join(Filter(Application.Transpose(Range("K21:K35").Value), "Blank", False), ",")
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Selection.Columns(Selection.Columns.Count), Order:=xlAscending, CustomOrder:="""" & sSortOrder & """"
With ActiveSheet.Sort
  .SetRange Selection
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
End With
 

tlc53

Active Member
Joined
Jul 26, 2018
Messages
365
Try this instead
Thanks Peter! Once I started looking into it, I realised it wasn't straight forward and a simple re-jig of my current code.

I have tried adding your new code (see below) but it doesn't appear to be working. Have I added it correctly? I can't see where it says which data it is going to sort, so I added Range("A52").Select so it would be in the right place.

Code:
Sub ClientNarrative()


    Range("A52").Select
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Sheets("Invoice Data").Columns("A:K").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("K20:K35"), CopyToRange:=Range("A52:K52"), Unique:= _
        False
            Range("A1").Select
            If Range("A53") = 0 Then Exit Sub
            Range("A52").Select


Dim sSortOrder As String


sSortOrder = Join(Filter(Application.Transpose(Range("K21:K35").Value), "Blank", False), ",")
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Selection.Columns(Selection.Columns.Count), Order:=xlAscending, CustomOrder:="""" & sSortOrder & """"
With ActiveSheet.Sort
  .SetRange Selection
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
End With
            


Application.ScreenUpdating = False
Dim r As Range
Dim cust As Range




Set r = Range("A52:K" & Range("A" & Rows.Count).End(xlUp).Row)
Set cust = Range("K20:K34")




cust.Offset(, 1).Value = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
r.Columns(11).Offset(1, 1).Resize(r.Rows.Count - 1).FormulaR1C1 = "=VLOOKUP(RC[-1],R20C11:R25C12,2,0)"
r.Value = r.Value
Set r = r.Resize(r.Rows.Count, r.Columns.Count + 1)
r.Sort key1:=[L52], order1:=xlAscending, Header:=xlYes
r.Columns(12).ClearContents
cust.Offset(, 1).Value = vbNullString
Application.ScreenUpdating = True


Range("A53").Select


    Selection.CurrentRegion.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
        End With
    Selection.Subtotal GroupBy:=11, Function:=xlSum, TotalList:=Array(6, 7, 9) _
        , Replace:=False, PageBreaks:=False, SummaryBelowData:=True
 
 
  Application.ScreenUpdating = False
  ActiveSheet.Outline.ShowLevels RowLevels:=2
  With Range("K" & Rows.Count).End(xlUp).CurrentRegion
    With .Offset(1).Resize(.Rows.Count - 1, 10).SpecialCells(xlVisible).Rows
      .Font.Bold = True
      .Interior.Color = 14277081
      .BorderAround xlContinuous
      .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
    With Intersect(.Columns(3), .SpecialCells(xlVisible), .SpecialCells(xlBlanks))
      .FormulaR1C1 = "=IF(RC[8]=""Grand Total"",RC[8],INDEX(Category,MATCH(LEFT(RC[8],LEN(RC[8])-6)+0,Criteria,0),1))"
    End With
  End With
  ActiveSheet.Outline.ShowLevels RowLevels:=3
  Application.ScreenUpdating = True


            Range("A1").Select
    End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,255
Office Version
365
Platform
Windows
I have tried adding your new code (see below) but it doesn't appear to be working. Have I added it correctly? I can't see where it says which data it is going to sort, so I added Range("A52").Select so it would be in the right place.
The reason that you cannot see which data should be sorted is because you didn't place the code where I suggested ..

... try adding this code immediately above the following line in your code
Selection.Subtotal GroupBy ....
If placed there it will still be acting on the selection you made with this part of your code
Code:
Range("A53").Select


    Selection.CurrentRegion.Select
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,102,774
Messages
5,488,774
Members
407,658
Latest member
Arias610

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top