Searching columns by header instead of the excel alphabets-CodePudding

I currently have a code as seen below that loops through 3 entire column and extracts out any value more than 0. This code uses columns that are explicitly identified in the code. In this case BQ ,BT and BW.

Option Explicit
Sub ID()
Dim ID0&, ID1&, ID2&, i&

Dim cell As Range
Dim arr(1 To 1000000, 1 To 2)
With Sheets("LOGS here")

    ID0 = .Cells(Rows.Count, "BQ").End(xlUp).Row
    ID1 = .Cells(Rows.Count, "BT").End(xlUp).Row
    ID2 = .Cells(Rows.Count, "BW").End(xlUp).Row
    For Each cell In .Range("BQ2:BQ" & ID0)
        If cell > 0 Then
            i = i   1
            arr(i, 1) = cell 'ID0
            arr(i, 2) = cell.Offset(, 133) 'Time
        End If
    Next
    For Each cell In .Range("BT2:BT" & ID1)
        If cell > 0 Then
            i = i   1
            arr(i, 1) = cell 'ID1
            arr(i, 2) = cell.Offset(, 130) 'Time
        End If
    Next
    For Each cell In .Range("BW2:BW" & ID2)
        If cell > 0 Then
            i = i   1
            arr(i, 1) = cell 'ID2
            arr(i, 2) = cell.Offset(, 127) 'Time
        End If
    Next
End With

Sheets("ID Pull Out").Cells(2, 1).Resize(i, 2).Value = arr

End Sub

But now I want to search for the column header instead, ID0, ID1 and ID2. Here is what i managed to do so far. The code is unable to loop through the entire column till the last row. Am I supposed to add End(xlUp).Row somewhere?

Sub IDNEW()

Dim ID0 As Range
Dim ID1 As Range
Dim ID2 As Range
Dim i
Dim cell As Range
Dim arr(1 To 10000, 1 To 2)

    Set ID0 = Worksheets("LOGS here").Range("A1:GS1").Find("ID0", LookAt:=xlWhole)
    Set ID1 = Worksheets("LOGS here").Range("A1:GS1").Find("ID1", LookAt:=xlWhole)
    Set ID2 = Worksheets("LOGS here").Range("A1:GS1").Find("ID2", LookAt:=xlWhole)

    For Each cell In ID0.Rows
        If cell > 0 Then
            i = i   1
            arr(i, 1) = cell 'ID0
            arr(i, 2) = cell.Offset(, 133) 'Time
        End If
    Next
    
    For Each cell In ID1.Rows
        If cell > 0 Then
            i = i   1
            arr(i, 1) = cell 'ID1
            arr(i, 2) = cell.Offset(, 130) 'Time
        End If
    Next
    
    For Each cell In ID2.Rows
        If cell > 0 Then
            i = i   1
            arr(i, 1) = cell 'ID2
            arr(i, 2) = cell.Offset(, 127) 'Time
        End If
    Next

Sheets("ID Pull Out").Cells(2, 1).Resize(i, 2).Value = arr

End Sub

I am still learning VBA and any help would be greatly appreciated.

CodePudding user response：

You can try something like this:

Sub IDNEW()

    Dim i As Long, n As Long
    Dim cell As Range, ws As Worksheet
    Dim arr(1 To 10000, 1 To 2), arrId, arrOffset, m, v
    
    arrId = Array("ID0", "ID1", "ID2") 'list of id's
    arrOffset = Array(133, 130, 127)   'list of corresponding column offsets
    
    Set ws = Worksheets("LOGS here")
    
    For n = LBound(arrId) To UBound(arrId)                        'loop the id's
        m = Application.match(arrId(n), ws.Range("A1:GS1"), 0)    'match the id on row 1
        If Not IsError(m) Then                                    'if not an error then found a match
            For Each cell In ws.Range(ws.Cells(2, m), ws.Cells(Rows.Count, m).End(xlUp)).Cells
                v = cell.Value
                If v > 0 Then
                    i = i   1
                    arr(i, 1) = v
                    arr(i, 2) = cell.Offset(0, arrOffset(n)).Value 'Time
                End If
            Next cell
        End If
    Next n
    
    Sheets("ID Pull Out").Cells(2, 1).Resize(i, 2).Value = arr

End Sub