excelvbaheaderrange

How to get data using header name ranges in Excel in case columns are dynamic?


I have here a simple form that matches data when ID is entered. It works fine. However, these columns are dynamic/interchangeable. What I would like to do is set the foundcell variable range from column numbers to header names so whenever the columns are interchanged, ID still has matching intact data after update.

Image of Sheet1 Data

sheet1

Text Data

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

So below is a sample matching data for ID 2.

form image

VBA Excel Code

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

Please advise. Thank you..


Solution

  • EDIT: switched back to Find() for matching the row....

    You could do something like this, using a Dictionary:

    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