VBA - Code to search in Header Row for String and Return Values in Column Below - Excel 2010

Johnny Thunder

Johnny Thunder

Well-known Member
Joined
Apr 9, 2010
Messages
693
Office Version
  1. 2016
Platform
  1. MacOS
Hi Everyone. I am in need of a code to populate a variance checklist for accounting purposes.

I have two sheets within one workbook, sheet "Tie out" that contains about 50 columns of data, but only 12 Variance columns. I need a code that can look at Row 1 and search for cells that contain the string "Variance" which identifies the columns I need to run a search in to check all cells example (C18: Lastrow). if a cell is found that is greater than 0.01 or less than -0.01 than get cell address and paste into a list on sheet "Found Variance".

There are times where there are multiple variances found within the same column so the code would need to loop and as it pastes the found criteria into the tab "Found Variance".

The Columns that contain the Variance Calculations can change and may not always be in the same column location hence the need for the search function as well the row count, currently the report has 150 rows starting from Row 18, rows 1:17 are headers and misc attributes.

Please let me know if I need to explain further. Any help on this is appreciated.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Try:

Code: 
Sub Macro1()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(2, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 1 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r + 1, c).Address(0, 0, 1, 0), 1
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:A").ClearContents
    Sheets("Found Variance").Range("A1") = "Cells"
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)


End Sub
 
Upvote 0
Thank you so much for looking into this Eric, I am getting a type mismatch error on the line below.

Code: 
If Abs(MyData(r, 1)) > 0.01 Then


Eric W said:
Try:

Code: 
Sub Macro1()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(2, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 1 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r + 1, c).Address(0, 0, 1, 0), 1
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:A").ClearContents
    Sheets("Found Variance").Range("A1") = "Cells"
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)


End Sub
Click to expand...
 
Upvote 0
You would get that problem if you only have one header column, or if you have non-numeric data in your range. If you want to put the non-numeric data on your list, just add a

Code: 
On Error Resume Next
line right after the Dim line. If you want to ignore non-numeric data, try:

Code: 
Sub Macro1()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            On Error GoTo Oops:
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(2, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 1 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r + 1, c).Address(0, 0, 1, 0), 1
NextR:
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:A").ClearContents
    Sheets("Found Variance").Range("A1") = "Cells"
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Exit Sub
Oops:
    Resume NextR:

End Sub
 
Upvote 0
Eric! You are amazing! It worked like a charm!

I wanted to ask, if I wanted to have the code also drop the actual Value of the Variance in Column (B) to the right of the cell address is that possible with a quick addition of a line of syntax? I should have thought that thru when I first posted the question.


Eric W said:
You would get that problem if you only have one header column, or if you have non-numeric data in your range. If you want to put the non-numeric data on your list, just add a

Code: 
On Error Resume Next
line right after the Dim line. If you want to ignore non-numeric data, try:

Code: 
Sub Macro1()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            On Error GoTo Oops:
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(2, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 1 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r + 1, c).Address(0, 0, 1, 0), 1
NextR:
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:A").ClearContents
    Sheets("Found Variance").Range("A1") = "Cells"
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Exit Sub
Oops:
    Resume NextR:

End Sub
Click to expand...
 
Upvote 0
Sure - I nearly included that anyway with my first version. I should have done it. Here it is:

Code: 
Sub Macro2()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            On Error GoTo Oops:
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(2, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 1 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r + 1, c).Address(0, 0, 1, 0), MyData(r, 1)
NextR:
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:B").ClearContents
    Sheets("Found Variance").Range("A1:B1") = Array("Cells", "Values")
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Sheets("Found Variance").Range("B2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.items)
    Exit Sub

Oops:
    Resume NextR:

End Sub
 
Upvote 0
Awesome, that worked perfectly. So, I had one last question. I tried to figure it out but I can't seem to track where the line of code needs to be updated but rows 1:17 have misc headers and titles, the actual data begins in row 18:lastrow. Right now the above code is taking in to account rows 2:lastrow I believe? How would you update the code so it looks at row 18:lastrow? All else is working flawlessly.

Eric W said:
Sure - I nearly included that anyway with my first version. I should have done it. Here it is:

Code: 
Sub Macro2()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            On Error GoTo Oops:
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(2, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 1 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r + 1, c).Address(0, 0, 1, 0), MyData(r, 1)
NextR:
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:B").ClearContents
    Sheets("Found Variance").Range("A1:B1") = Array("Cells", "Values")
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Sheets("Found Variance").Range("B2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.items)
    Exit Sub

Oops:
    Resume NextR:

End Sub
Click to expand...
 
Upvote 0
I was trying to save a little storage space, but it made the macro a little more complicated. Try this:

Rich (BB code): 
Sub Macro2()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            On Error GoTo Oops:
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(1, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 18 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r, c).Address(0, 0, 1, 0), MyData(r, 1)
NextR:
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:B").ClearContents
    Sheets("Found Variance").Range("A1:B1") = Array("Cells", "Values")
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Sheets("Found Variance").Range("B2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.items)
    Exit Sub

Oops:
    Resume NextR:

End Sub
The parts in red I changed.
 
Upvote 0
Not all heroes wear capes.... you are my hero today Eric!

Thanks a million! And thank you for pointing out what was changed. It helps for me to try and recreate this in the future.

Eric W said:
I was trying to save a little storage space, but it made the macro a little more complicated. Try this:

Rich (BB code): 
Sub Macro2()
Dim Headers As Variant, MyData As Variant, MyDict As Object, r As Long, c As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    With Sheets("Tie Out")
        Headers = .Range("A1").Resize(, .Cells(1, Columns.Count).End(xlToLeft).Column).Value
        For c = 1 To UBound(Headers, 2)
            On Error GoTo Oops:
            If InStr(LCase(Headers(1, c)), "variance") > 0 Then
                MyData = .Range(.Cells(1, c), .Cells(.Cells(Rows.Count, c).End(xlUp).Row, c)).Value
                For r = 18 To UBound(MyData)
                    If Abs(MyData(r, 1)) > 0.01 Then MyDict.Add Cells(r, c).Address(0, 0, 1, 0), MyData(r, 1)
NextR:
                Next r
            End If
        Next c
    End With
    
    Sheets("Found Variance").Range("A:B").ClearContents
    Sheets("Found Variance").Range("A1:B1") = Array("Cells", "Values")
    Sheets("Found Variance").Range("A2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.keys)
    Sheets("Found Variance").Range("B2").Resize(MyDict.Count) = WorksheetFunction.Transpose(MyDict.items)
    Exit Sub

Oops:
    Resume NextR:

End Sub
The parts in red I changed.
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA Search box and button code
Replies
0
Views
272
jlcodes
J
C
  • Solved
Calculating Totals between two column headers - Macro VBA
Replies
9
Views
123
Fuji
F
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
189
sijpie
sijpie
C
  • Solved
Macro/VBA for lookups
Replies
9
Views
183
mumps
mumps
C
  • Question Question
String Finding
Replies
4
Views
396
abdelfattah
A

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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