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.

 

[Johnny Thunder]

Eric, So I have been working with the code and it is great but I just ran into a peculiar scenario.... If there is no variances the code just keeps on running?

To test, I manually entered a variance and within seconds the code stops and returns the manually added variance. Remove that, and the code just keeps on running? Any idea on how to adjust to have it end in the event it doesn't find anything?

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.

 

[Eric W]

I should have tested for that.

    Sheets("Found Variance").Range("A1:B1") = Array("Cells", "Values")
    If MyDict.Count = 0 Then Exit Sub

Look for the first line, then add the next line right after it.

 

[Johnny Thunder]

Perfect. Thanks again for the quick reply. I think I have tested just about every scenario possible now.