VBA - Format Rows containing word 'Total'

[tlc53]

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!

 

[Peter_SSs]

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?

 

[tlc53]

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]

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.

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

 

[tlc53]

See how it goes.

*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!!

 

[Peter_SSs]

*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]

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?

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]

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.

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]

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

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]

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.

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]

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

Range("A53").Select


    Selection.CurrentRegion.Select