VBA - Format Rows containing word 'Total'

tlc53

Active Member
Joined
Jul 26, 2018
Messages
399
Hi,
I'm using the function Subtotal on my Defined Name range. I would like to format the totals that come through, so that they stand out from the rest of the data. I would like to do this without necessary referring to exact rows/cells, so that the format will work even if the data changes.
My named range is 'CordisTest1'
My data headings are always on row 52
K52 is for heading 'Account' and is what the Subtotal function is based on.
I would like it if column K in my named range 'CordisTest1' contains the word 'Total', cells A:J to the left of it will be formatted to have a plain line border around only, fill 15% grey and be bold font.
Not sure if this is even possible. If not, please could you let me know. Thank you!
 
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?
 
Upvote 0

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
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
 
Upvote 0
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
 
Upvote 0
*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. :)
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,176
Members
448,554
Latest member
Gleisner2

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