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

[Johnny Thunder]

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.

 

[Eric W]

Try:

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

 

[Johnny Thunder]

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

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

Try:

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

 

[Johnny Thunder]

Eric,

Here is a link to a sample file if that helps.

https://drive.google.com/open?id=19YiaaQP6rHlMZaUrpAXlIRLU9Su0EdwX

Thanks again.

 

[Eric W]

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

On Error Resume Next

line right after the Dim line. If you want to ignore non-numeric data, try:

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

 

[Johnny Thunder]

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.

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

On Error Resume Next

line right after the Dim line. If you want to ignore non-numeric data, try:

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

 

[Eric W]

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

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

 

[Johnny Thunder]

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.

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

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

 

[Eric W]

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

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.

 

[Johnny Thunder]

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.

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

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.