按 header 而不是 excel 字母搜索列

Question

我目前有一个如下所示的代码，它循环遍历 3 个整列并提取出大于 0 的任何值。此代码使用代码中明确标识的列。在这种情况下，BQ、BT 和 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

但现在我想搜索列 header，而不是 ID0、ID1 和 ID2。到目前为止，这是我设法做到的。代码无法遍历整列直到最后一行。我应该在某处添加 End(xlUp).Row 吗？

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

我仍在学习VBA，如有任何帮助，我们将不胜感激。

Answer 1

您可以尝试这样的操作：

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

按 header 而不是 excel 字母搜索列

Searching columns by header instead of the excel alphabets

excel

vba