填充列索引

的数据

主要

Sub PopulateColumnIndexes()
    
    Const PROC_TITLE As String = "Populate Column Indexes"
    Const WORKSHEET_NAME As String = "Billings"
    Const FIRST_ROW As Long = 2
    Const SRC_COLUMN As Long = 2
    Const DST_COLUMN As Long = 3
    Const NOT_FOUND_VALUE As Variant = Empty
    Const MESSAGE_YES As String = "Column indexes populated."
    Const MESSAGE_NO As String = "Couldn't find the following locations:"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets(WORKSHEET_NAME)
    Dim RowOffset As Long: RowOffset = FIRST_ROW - 1
    
    Dim srg As Range, drg As Range
    
    With ws.UsedRange
        With .Resize(.Rows.Count - RowOffset).Offset(RowOffset)
            Set srg = .Columns(SRC_COLUMN)
            Set drg = .Columns(DST_COLUMN)
        End With
    End With
    
    Dim Data(): Data = srg.Value
    Dim Locations As Object: Set Locations = LocationsToDictionary
    Dim NoLocs As Object: Set NoLocs = CreateObject("Scripting.Dictionary")
    NoLocs.CompareMode = vbTextCompare
    
    Dim r As Long, rStr As String, sAddress As String, IsFound As Boolean
    
    For r = 1 To UBound(Data, 1)
        rStr = CStr(Data(r, 1))
        If Len(rStr) > 0 Then
            If Locations.Exists(rStr) Then IsFound = True
        End If
        If IsFound Then
            IsFound = False
            Data(r, 1) = Locations(rStr)
        Else
            Data(r, 1) = NOT_FOUND_VALUE
            sAddress = srg.Cells(r).Address(0, 0)
            If NoLocs.Exists(rStr) Then
                NoLocs(rStr) = NoLocs(rStr) & ", " & sAddress
            Else
                NoLocs(rStr) = """" & rStr & """ in " & sAddress
            End If
        End If
    Next r
    
    drg.Value = Data
    
    If NoLocs.Count = 0 Then
        MsgBox MESSAGE_YES, vbInformation, PROC_TITLE
    Else
        MsgBox MESSAGE_NO & vbLf & vbLf & Join(NoLocs.Items, vbLf), _
            vbExclamation, PROC_TITLE
    End If

End Sub

字符串

帮助

Function LocationsToDictionary() As Object
    
    Const WORKSHEET_NAME As String = "Database Names"
    Const FIRST_ROW As Long = 1
    Const FIRST_COLUMN As Long = 2
    Const NEXT_COLUMN_ON_FIRST_BLANK As Boolean = True ' boosts efficiency
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets(WORKSHEET_NAME)
    
    Dim Data(): Data = ws.UsedRange.Value
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim cCount As Long: cCount = UBound(Data, 2)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim c As Long, r As Long, rStr As String
    
    For c = FIRST_COLUMN To cCount
        For r = FIRST_ROW To rCount
            rStr = CStr(Data(r, c))
            If Len(rStr) = 0 Then
                If NEXT_COLUMN_ON_FIRST_BLANK Then Exit For
            Else
                If Not dict.Exists(rStr) Then dict(rStr) = c
            End If
        Next r
    Next c
       
    Set LocationsToDictionary = dict

End Function

型

Excel公式（Microsoft365）

=LET(dlData,B2:B11,slData,'Database Names'!B1:C4,sfcIndex,2,Er,"",
    sl,TOCOL(IF(slData="","",slData),,1),lm,XMATCH(dlData,sl),
    dr,IFERROR(INT((lm-1)/ROWS(slData))+sfcIndex,Er),
dr)

型
或者是

=LET(dlData,B2:B11,slData,'Database Names'!B1:C4,sfcIndex,2,Er,"",
    sl,TOCOL(IF(slData="","",slData),,1),
    sr,INT((SEQUENCE(ROWS(sl))-1)/ROWS(slData)),
    dr,IFERROR(XLOOKUP(dlData,sl,sr)+sfcIndex,Er),
dr)

型

此解决方案使用Scripting.Dictionary来存储要查找的城市代码。除此之外，它遵循与OP使用的大致相同的结构和名称。

'// ALWAYS use option explicit
    Option Explicit
    
        '// Declare the variables to be used
        Dim columnLocationList As Range
        Dim columnLocations As Range
        Dim locations As Range
        
        '// Lookup dictionary for location -> column number
        Dim dictLocations As Scripting.Dictionary
        
    Public Sub GetCityColumnNumbers()
    
        Debug.Print "Start", Now

        '// Load the dictionary with city -> column lookups
        loadDictLocations
        
        '// Establish the list of cities
        With Sheets("Billings").Range("b1")
            Set columnLocationList = Range(.Cells(2), .End(xlDown))
            columnLocationList.Offset(0, 1).ClearContents
            columnLocationList.Style = "Normal"
        End With
        
        '// Process all the cities
        For Each columnLocations In columnLocationList
            With columnLocations
                If dictLocations.Exists(.Value) Then
                    .Offset(0, 1).Value = dictLocations.Item(.Value)
                Else
                    '// Highlight entries not found
                    .Offset(0, 1).ClearContents
                    .Style = "Bad"
                End If
            End With
        Next columnLocations
        
        
        Debug.Print "End", Now
        
    End Sub
    
    
    Public Sub loadDictLocations()
        
        Set dictLocations = New Scripting.Dictionary
        For Each locations In Sheets("Database Names").UsedRange
            Select Case True
            '// Ignore empty, blank or duplicate cells
            Case Len(locations.Value) = 0
            Case dictLocations.Exists(locations.Value)
                '// Highlight duplicate city code
                locations.Style = "Bad"
            Case Else
                dictLocations.Add locations.Value, locations.Column
            End Select
        Next locations

        Debug.Print "Dictionary loaded"
        
    End Sub

字符串