VBA - Format Rows containing word 'Total'

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
43,401
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

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

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
43,401
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
43,401
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
43,401
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
43,401
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
43,401
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:

Forum statistics

Threads
1,089,201
Messages
5,406,808
Members
403,106
Latest member
AliO

This Week's Hot Topics

Top