代码之家 › 专栏 › 技术社区 › Shiela

如果列是动态的,如何在Excel中使用标题名称范围获取数据?

range header vba excel

Shiela · 技术社区 · 2 年前

我在这里有一个简单的表单,当输入ID时匹配数据。它运行良好。但是,这些列是动态的/可互换的。我想做的是设置 foundcell variable range 从列编号到标题名称 因此,每当交换列时,ID在更新后仍然具有匹配的完整数据。

Sheet1数据的图像

文本数据

ID  Description 1   Description 2   Description 3   Description 4
1       Abc             123             Red             Yes
2       Def             456             Blue            Yes
3       Ghi             789             Orange          Yes
4       Jkl             0               Yellow          No

下面是ID 2的匹配数据示例。

VBA Excel代码

Private Sub id_Change()
Dim id As Variant, rowcount As Integer, foundcell As Range
id = Me.id.value
    rowcount = ThisWorkbook.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).row
        With ThisWorkbook.Sheets("Sheet1").Range("A1:A" & rowcount)
        Set foundcell = .Find(what:=id, LookIn:=xlValues)
          If Not foundcell Is Nothing Then                
                desc1.value = .Cells(foundcell.row, 2) 'I would like to name this as Description 1
                desc2.value = .Cells(foundcell.row, 3) 'I would like to name this as Description 2
                desc3.value = .Cells(foundcell.row, 4) 'I would like to name this as Description 3
                desc4.value = .Cells(foundcell.row, 5) 'I would like to name this as Description 4
            Else
                 desc1.value = ""
                 desc2.value = ""
                 desc3.value = ""
                 desc4.value = ""
            End If
        End With
End Sub

请告知。非常感谢。

1 回复 | 直到 2 年前

Tim Williams 2 年前

EDIT:切换回Find()以匹配行。。。。

您可以使用字典执行以下操作:

Private Sub id_Change()
    Dim id As Variant, headers As Object, ws As Worksheet, f As range
    id = Me.id.Value
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set headers = AllHeaders(ws, 1) 'get column headers from first row
    Set f = ws.Columns(headers("ID")).Find(id, Lookat:=xlWhole, _
                                             Lookin:=xlValues)
    If Not f Is Nothing Then
        With f.EntireRow
            desc1.Value = .Cells(headers("Description 1"))
            desc2.Value = .Cells(headers("Description 2"))
            desc3.Value = .Cells(headers("Description 3"))
            desc4.Value = .Cells(headers("Description 4"))
        End With
    Else
        desc1.Value = ""
        desc2.Value = ""
        desc3.Value = ""
        desc4.Value = ""
    End If
End Sub

'Return a Dictionary mapping all headers on row `rw` of sheet `ws`
'   to their column positions.  Assumes all headers are unique.
Function AllHeaders(ws As Worksheet, rw As Long) As Object
    Dim dict As Object, v As String, c As Range
    Set dict = CreateObject("scripting.dictionary")
    dict.comparemode = 1 'vbTextCompare: case-insensitive
    For Each c In ws.Range(ws.Cells(rw, 1), ws.Cells(rw, Columns.Count).End(xlToLeft)).Cells
        v = c.Value
        If Len(v) > 0 Then dict.Add v, c.Column 'map headers to column number
    Next c
    Set AllHeaders = dict
End Function