Solved: Selecting subtotal and grand total cells only(not entire row)

[woody3737]

For the large amount of tables I create daily I am making a macro that will select the header, subtotal, and grand total rows so I can then format things like the border, font, color, etc. The reason for this is I can have several dozen subtotal rows and it gets to be time consuming to manually highlight each one of them. I have the code for all the formatting I need. For the header, since it always start in A3, I am using the following code:

 
Dim Rng As Range
Set Rng = Range("A3").CurrentRegion.Rows(1)

What I can't figure out is how to have the macro find and select the subtotal and grand total cells and not the entire row since they are never in the same spot. I figured it could be done using some kind of search function in column A for "Total" where any time it came across it, it would select the cell and some variation of the code above would select the rest of the row out to the last cell with data. What would that search function look like? Also, what would I replace "A3" with since the range will never be the same? Would "ActiveCell" work? Thanks in advance for any help.

[mdmackillop]

Hi Woody,
Welcome to VBAX.
Can you post a sample workbook showing the formuale and formatting? Use Manage Attachments in the Go Advanced reply section.
Regards
MD

[MaximS]

try this, should give you few ideas:

[vba]
Option Explicit
Sub Formating()
Dim Wb As Workbook
Dim Sh As Worksheet
Dim LRow, i, y As Long
Dim x As String

Set Wb = ThisWorkbook
Set Sh = Wb.Worksheets(1)

LRow = Sh.Range("A" & Rows.Count).End(xlUp).Row

y = 0
Do While y < LRow
On Error Resume Next
' Change column letter and word "Total" whenever needed
x = WorksheetFunction.Match("Total", _
Sh.Range("A" & y + 1 & ":A" & LRow), 0)
On Error GoTo 0
If x <> "" Then
'Change range to include full row and formating if needed
Sh.Range("A" & y + x).Interior.ColorIndex = 6
Else
Exit Sub
End If
y = y + x
x = ""
Loop
End Sub
[/vba]

[woody3737]

Thanks to both of you for the replies. Sorry for the late response, but I have been away from the office for the last few days.

mdmackillop, I have attached a file that shows a few examples of the tables I am dealing with. Again, these will always change in size and structure depending on what they are being used for. Also, in my first post I stated that I had figured out how to select the header since it always starts in A3, but I was mistaken. I hadn't tested it enough and now can't figure out what part of the code to change to correct this. Here is the code as it is now, which only applies the format to A3:

 
Sub FormatHeaderChunk()
'
' FormatHeader Macro
'
'
    Range("A3").Select
    Dim Rng As Range
    Set Rng = Range("A3").CurrentRegion.Rows(1)
    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(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
End Sub

MaximS, thanks for the suggestion. I tried this and it didn't seem to do anything. It's wierd. I get no error message and nothing moves or changes in the spreadsheet. I've never seen that before as far as macros go. I do appreciate the ideas, but your code is a little beyond my level of experience. Do you have any suggestions on what alterations I might need to make?

Thanks again for the help.

[Bob Phillips]

[vba]

Sub FormatHeaderChunk()
Dim rng As Range
Dim cell As Range
Dim FirstAddress As String

Call FormatCells(Range("A3"))
With Columns(1)

Set cell = .Find("Total", Lookat:=xlPart)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
Call FormatCells(cell)
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> FirstAddress
End If
End With
End Sub

Private Function FormatCells(rng As Range)

With rng.Resize(, rng.End(xlToRight).Column)

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Font.Bold = True
End With
End Function
[/vba]

[woody3737]

Thanks xld for the quick response. The code works great for the header and grand total rows when the table does not contain any subtotals. When there are subtotals, for some reason, it is having trouble. It correctly finds the subtotal and grand total rows that need to be formatted, but instead of extending the selection to the last cell with data, it only selects out to column C. I may be way off base, but the only thing I can think of that could be causing this is that column B is blank. I have included a sample table as it looks after the code is run. Again, it works great when there are no subtotals. Thanks again for the help.

[Bob Phillips]

[vba]

Sub FormatHeaderChunk()
Dim rng As Range
Dim cell As Range
Dim FirstAddress As String

Call FormatCells(Range("A3"))
With Columns(1)

Set cell = .Find("Total", Lookat:=xlPart)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
Call FormatCells(cell)
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> FirstAddress
End If
End With
End Sub

Private Function FormatCells(rng As Range)

With rng

With .Resize(, .Parent.Cells(.Row, .Parent.Columns.Count).End(xlToLeft).Column)

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
.Font.Bold = True
End With
End With
End Function
[/vba]

[woody3737]

xld, that works great. Thank you very much. I have to apologize because, in my haste, I failed to mention that I have subtotals that start in columns A, B, & C. Do i need to repeat this 2 more times, changing "A3" to "B3" and then "C3" or do I need to do some kind of loop to account for these subtotal rows? Sorry again for the ommision.

[Bob Phillips]

No, better to do it in the same pass, like so

[vba]

Sub FormatHeaderChunk()
Dim rng As Range
Dim cell As Range
Dim FirstAddress As String
Dim LastCol As Long

LastCol = Cells(3, Parent.Columns.Count).End(xlToLeft).Column

Call FormatCells(Range("A3"), LastCol)
With Columns("A:C")

Set cell = .Find("Total", Lookat:=xlPart)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
Call FormatCells(cell, LastCol)
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> FirstAddress
End If
End With
End Sub

Private Function FormatCells(rng As Range, NumCols As Long)

With rng.Offset(0, 1 - rng.Column).Resize(, NumCols)

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
.Font.Bold = True
End With
End Function
[/vba]

[woody3737]

Very nice, subtle changes. There is so much about VBA I can learn from that first chunk of code. Thanks so much.

One question. I'm splitting hairs here and if this isn't a minor fix just tell me to take a flying leap off of a cliff. Assume there is a subtotal starting in B6. Right now, the code will select A6:end of data and apply the formatting, instead of just B6:end of data. The same can be said if a subtotal was in column C. It's not a huge problem, it just isn't all that easy on the eyes when trying to qucikly jump from one set of totals to another. Again, if it's not a quick fix, then see above! Thanks again for all of your help.

[Bob Phillips]

LOL, I did that deliberately, because it didn't look right to me when I started in column B say.

[vba]

Sub FormatHeaderChunk()
Dim rng As Range
Dim cell As Range
Dim FirstAddress As String
Dim LastCol As Long

LastCol = Cells(3, Parent.Columns.Count).End(xlToLeft).Column

Call FormatCells(Range("A3"), LastCol)
With Columns("A:C")

Set cell = .Find("Total", Lookat:=xlPart)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
Call FormatCells(cell, LastCol)
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> FirstAddress
End If
End With
End Sub

Private Function FormatCells(rng As Range, NumCols As Long)

With rng.Resize(, NumCols - rng.Column + 1)

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlThin
End With
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
.Font.Bold = True
End With
End Function[/vba]

[woody3737]

It's amazing how quickly you VBA experts can come up with this stuff on the fly.

One last question and I'll leave you alone. I'm still having trouble understanding all of the different methods to find and select the last row/column of data. In this case, what bit of code would I tack on so it puts a thin border around the entire table, "A3:last column & last row of data"? Do you know of a reference, off the top of your head, that discusses these various methods? I bought an instructional book from Mrexcel.com, but am still waiting for it in the mail.

[Bob Phillips]

[vba]

Sub FormatHeaderChunk()
Dim rng As Range
Dim cell As Range
Dim FirstAddress As String
Dim LastRow As Long
Dim LastCol As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastCol = Cells(3, Columns.Count).End(xlToLeft).Column

Call FormatCells(Range("A3"), LastCol)
With Columns("A:C")

Set cell = .Find("Total", Lookat:=xlPart)
If Not cell Is Nothing Then
FirstAddress = cell.Address
Do
Call FormatCells(cell, LastCol)
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> FirstAddress
End If
End With
Range("A3").Resize(LastRow - 2, LastCol).BorderAround LineStyle:=xlContinuous, ColorIndex:=xlColorIndexAutomatic
End Sub
[/vba]

[woody3737]

Thanks so much for everything, oh Distinguished Lord. I appreciate you sticking with this through all of my ignorance.