VBA code to auto highlight region from a fixed point

K

KlayontKress

Board Regular
Joined
Jan 20, 2016
Messages
67
Office Version
  1. 2016
Platform
  1. Windows
To all,


I'm looking for a macro to auto select a region from a fixed point, E6, down to the last row in the column with data (the column has non continuous data), and as far right as there are columns that have data and add thin borders. This is a secondary request for a previous post I received help on. The data format will be similar to the table at the bottom of this post but there many be hundreds of rows.


I tried to record a macro to do this and it gave me the large section of code at the bottom of the post to select this region. The problem I have, is the range is running from cell E1 to the last row with data in it all the way to the last column possible in the worksheet. I thought that the code
Code: 
Range(Selection, Selection.End(xlDown)).Select
would change the selection from the top of the worksheet to the first row with data in it but this doesn't seem to be working.


Code: 
Range("E1").Select

'following code is to find the bottom of the page
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select

'code looks up to find the last row
    Selection.End(xlUp).Select
'code selectes from the last cell to the top of the sheet
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
'code selects from the top of the sheet to the first row with data in it
    Range(Selection, Selection.End(xlDown)).Select
'at this point, I should have everything from the last row to the first row selected

'code selects all of the columns to the right with data
    Range(Selection, Selection.End(xlToRight)).Select

'code below adds the borders
    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
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
1
BLAH
2
BLAH
3
BLAH
4
BLAH
5
6
DESCRIPTION
QTY
MODIFICATIONS
OPTIONS
COLOR 1
COLOR 2
COLOR 3
COLOR 4
7
ASDF
#
ASDF,ASDF
$$
$
$$$
$
8
ASDF
#
FDSA
$
$$
$
$$
9
10
ASDF
#
FDSA
$$
$$
$
$$$
11
ASDF
#
$$
$
$$$
$
12
ASDF
#
ASDF
$
$$$
$$
$$
13
14
(WANT TO INSERT TOTAL HERE)
(WANT TO TOTAL COLUMN FROM E7:E12)
(WANT TO TOTAL COLUMN FROM F7:F12)
(WANT TO TOTAL COLUMN FROM G7:G12)
(WANT TO TOTAL COLUMN FROM H7:H12)

<tbody>
</tbody>


Thanks in advance,
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Sort by date Sort by votes
Try this
Code: 
Sub AddBorder()

    Dim UsdRws As Long
    Dim UsdCols As Long
    Dim Rng As Range

    UsdRws = Range("E" & Rows.Count).End(xlUp).Row
    UsdCols = Cells(6, Columns.Count).End(xlToLeft).Column
    Set Rng = Range("E6", Cells(UsdRws, UsdCols))

    Rng.BorderAround Weight:=xlThin
    Rng.Borders(xlInsideVertical).Weight = xlThin
    Rng.Borders(xlInsideHorizontal).Weight = xlThin

End Sub
 
Upvote 0
Is this code separate form the one that is adding the totals?

If is the same sub then you can add the bottom and use the total row and last column that was already found
Code: 
Sub AddTotals()

Dim TotRw As Long
Dim UsdCols As Long
    
TotRw = Range("A" & Rows.Count).End(xlUp).Offset(2).Row
UsdCols = Cells(6, Columns.Count).End(xlToLeft).Column
    
Range("A" & TotRw).Value = "Total"
Range("E" & TotRw).Resize(, UsdCols - 4).FormulaR1C1 = "=sum(r7c:r[-2]c)"
    
'add borders
Set Rng = Range(Cells(7, 5), Cells(TotRw - 2, UsdCols))
    With Rng.Borders
        .LineStyle = xlContinuous
        
        .Weight = xlThin
    End With
    

End Sub
 
Upvote 0
Fluff and Scott,


thank you for the quick responses. While I was waiting I started looking up VBA courses because I struggle with defining dynamic ranges in VBA

I found this code to do what both of you have also provided answers to.
Code: 
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range

Set StartCell = Range("E6")

'Find Last Row and Column
  LastRow = Cells(Rows.Count, StartCell.Column).End(xlUp).Row
  LastColumn = Cells(StartCell.Row, Columns.Count).End(xlToLeft).Column

'Select Range
  Range(StartCell, Cells(LastRow, LastColumn)).Select

I know it may be beyond the scope of this post as I tested both of your answers and both of them work (yay for having a solution), but can either of you give an explanation as to what each piece is doing in your code?
I know that this macro is starting in cell E6 and that it is looking for the last row with data in it and the last column with data in it.
I also think that this has the limitation that the column with the starting point must have data in the last row you want to select and the row where the starting point is must have data in the last column you want to select.

I guess my real question is, how or where do you learn what the terms to put into the macro are? Such as lastrow, last column, rows.count etc?
Do either of you know a good place to learn this? I've pick up how to write macros and can usually adapt something I have found or been given to another application with trial and error.


Scott, to answer your question, yes this is the same sub. In fact, the entire code is posted below. I'm sure to an experienced coder it looks like Frankenstein's Monster but it seems to be getting the job done. I still need to clean some of the code up, but it is largely formatting and auto moving information around that we have on quotes for our customers. We have approximately 36k of these files, and when we do a pricing change, we have to update them all. Automating this will save the department hundreds of hours as they will simply have to re-export the quote from company built software, run this macro and save it.

Code: 
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+z



'========================================================================
' DELETES ALL ROWS FROM A2 DOWNWARDS WITH THE WORDs "Total" IN COLUMN A
'========================================================================
    Last = Cells(Rows.Count, "A").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "A").Value) = "Total" Then
            Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
            'Cells(i, "A").EntireRow.Delete ' Use this to delete the entire row
        End If
    Next i

'========================================================================
' DELETES ALL ROWS FROM A2 DOWNWARDS WITH THE WORDs "Tax" IN COLUMN A
'========================================================================
    Last = Cells(Rows.Count, "A").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "A").Value) = "Tax" Then
            Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
            'Cells(i, "A").EntireRow.Delete ' Use this to delete the entire row
        End If
    Next i

'========================================================================
' DELETES ALL ROWS FROM A2 DOWNWARDS WITH THE WORDs "Grand Total" IN COLUMN A
'========================================================================
    Last = Cells(Rows.Count, "A").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "A").Value) = "Grand Total" Then
            Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
            'Cells(i, "A").EntireRow.Delete ' Use this to delete the entire row
        End If
    Next i
    
'========================================================================
'Delete extra columns from Column "K" over ***Change as Needed***
'========================================================================
    'Columns("K:K").Select
    'Range(Selection, Selection.End(xlToRight)).Select
    'Selection.Delete Shift:=xlToLeft

'------------------------------------------------------------------------

    Rows("1:5").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.NumberFormat = "General"
    
    Columns("C:D").Select
    Selection.EntireColumn.Hidden = True
    
    Rows("6:6").Select
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    With Selection.Font
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "SIMPLY RYAN"
    
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "KC NBR HOUSE TYPE"
    
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "ROOM TYPE"
    
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    
    Range("A4").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Range("A1:A2").Select
    Selection.Font.Bold = True
    
    Columns("B:B").ColumnWidth = 6
    
    Columns("A:A").Select
    Columns("A:A").EntireColumn.AutoFit

    Range("E1").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Columns("G:G").Select
    Selection.Copy
    
    Columns("H:H").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
'========================================================================
'Auto Total Columns
'========================================================================
    Dim TotRw As Long
    Dim UsdCols As Long
    
    TotRw = Range("A" & Rows.Count).End(xlUp).Offset(2).Row
    UsdCols = Cells(6, Columns.Count).End(xlToLeft).Column
    
    Range("A" & TotRw).Value = "Total"
    Range("E" & TotRw).Resize(, UsdCols - 4).FormulaR1C1 = "=sum(r7c:r[-2]c)"
    
'========================================================================
'Add Shading Automatically
'========================================================================
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range

Set StartCell = Range("E6")

'Find Last Row and Column
  LastRow = Cells(Rows.Count, StartCell.Column).End(xlUp).Row
  LastColumn = Cells(StartCell.Row, Columns.Count).End(xlToLeft).Column

'Select Range
  Range(StartCell, Cells(LastRow, LastColumn)).Select
    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
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

'========================================================================
'Shade NA Cells
'========================================================================

    Selection.FormatConditions.Add Type:=xlTextString, String:="NA", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249946592608417
    End With
    Selection.FormatConditions(1).StopIfTrue = True
  
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'BEGINNING OF OPTIONS MACRO
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx


'========================================================================
'ID Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=4" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 4"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=5" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 5"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=6" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 6"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=7" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 7"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=8" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 8"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=9" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 9"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=10" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 10"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=11" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 11"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=12" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 12"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=13" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 13"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=14" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 14"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=15" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 15"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=16" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 16"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=17" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 17"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=18" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 18"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=19" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 19"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=20" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 20"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=21" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 21"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=22" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 22"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=23" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 23"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "ID=24" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", ID 24"
        End If
Next
'========================================================================
'RD Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=4" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 4"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=5" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 5"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=6" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 6"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=7" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 7"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=8" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 8"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=9" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 9"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=10" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 10"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=11" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 11"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=12" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 12"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=13" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 13"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=14" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 14"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=15" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 15"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=16" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 16"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=17" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 17"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=18" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 18"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=19" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 19"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=20" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 20"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=21" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 21"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=22" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 22"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=23" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 23"
        End If
Next
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "RD=24" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", RD 24"
        End If
Next
'========================================================================
'MI Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "MI" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", MI"
        End If
Next
'========================================================================
'FEDEP Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 3) Like "*" & "FEDEP" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", FE"
        End If
Next
'========================================================================
'OFD Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "VD=OFD" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", OFD"
        End If
Next
'========================================================================
'MFD Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "VD=MFD" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", MFD"
        End If
Next
'========================================================================
'GLS Search
'========================================================================
lRow = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row
For i = 2 To lRow
        If Cells(i, 4) Like "*" & "=Clr" & "*" Then
            Cells(i, 1) = Cells(i, 1) & ", Clear"
        End If
Next
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'End OF OPTIONS MACRO
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

'========================================================================
'Auto Fit Column "A" after Modifications are Added
'========================================================================
    Columns("A:A").EntireColumn.AutoFit

End Sub
 
Upvote 0
Here is a you tube channel that teaches Excel VBA. He also has a Udemy course on Excel VBA.

https://www.youtube.com/user/ExcelVbaIsFun/videos


Code with comments

Code: 
Sub AddTotals()

Dim TotRw As Long
Dim UsdCols As Long
    
TotRw = Range("A" & Rows.Count).End(xlUp).Offset(2).Row 'finds last row used in A and then goes down two rows this is the row the total will be put
UsdCols = Cells(6, Columns.Count).End(xlToLeft).Column 'finds the last column used based on headers in row 6
    
Range("A" & TotRw).Value = "Total" 'adds the word Total
Range("E" & TotRw).Resize(, UsdCols - 4).FormulaR1C1 = "=sum(r7c:r[-2]c)" 'sum the data
    
    
    
Set Rng = Range(Cells(7, 5), Cells(TotRw - 2, UsdCols)) 'sets the range to E7:last column used and row 2 rows above the total row
    With Rng.Borders 'adds the borders to the range
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    

End Sub
 
Upvote 0
Scott,

Much appreciated for the annotation. I will check out that YT site when I get home.

Thank you again
 
Upvote 0
@KlayontKress
Regarding this
I also think that this has the limitation that the column with the starting point must have data in the last row you want to select and the row where the starting point is must have data in the last column you want to select.
Click to expand...
If you're data is unpredictable you can use
Code: 
    UsdRws = Cells.Find("*", after:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    UsdCols = Cells.Find("*", after:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
to find the last row/col. Where you are simply finding anything.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
332
RoryA
RoryA
K
  • Solved
formating question
Replies
3
Views
74
Micron
M
P
  • Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
188
6StringJazzer
6StringJazzer
J
  • Question
Issue with Macros and renaming files
Replies
6
Views
503
kevin9999
K
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
863
kerm007
K

Forum statistics

Threads
1,215,006
Messages
6,122,666
Members
449,091
Latest member
peppernaut

Share this page

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