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

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
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
247
jlcodes
J
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
158
sijpie
sijpie
C
  • Question Question
String Finding
Replies
4
Views
385
abdelfattah
A
C
  • Question Question
Using pattern searches with a variable to find the correct values
2
Replies
10
Views
195
chazrab
C
J
  • Question Question
Search folder for value and list left/right value
Replies
2
Views
220
JJCam
J

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

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