excel - VBA:使用 .Find 方法查找第一个和第二个值的出现

Question

我有这些列 列标题 是字符串，后跟随机数。
我想将第一次和第二次出现更改为特定字符串。这些列可以是随机顺序，但较小的数字(或没有数字)有资格作为第一次出现。
输入:


姓名
日期2
地点33
名称2
日期14
地点666


输出:


转移名称
转让日期
转移地点
发件者姓名
发件人日期
发件人地点


我希望房产SearchOrder=xlnext有助于识别第一个值，但我错了。
规则是即使缺少该列，从左侧开始的第一个匹配项也会被标记为 Transfer.。 .
我用选项 LookAt:=xlPart 尝试了多种方法结合 *通配符无济于事。
我使用的代码是:

Dim sht As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long

fndList = Array("name", "date", "place", "name*", "date*", "place*")
rplcList = Array("Transfer.name", "Transfer.date", "Transfer.place",_
 "Sender.name", "Sender.date", "Sender.place")

'Loop through each item in Array lists
For x = LBound(fndList) To UBound(fndList)
On Error GoTo NextList:
        Worksheets("Header").Rows(1).Replace What:=fndList(x), Replacement:=rplcList(x), _
          LookAt:=xlWhole, SearchOrder:=xlNext, MatchCase:=False, _
          SearchFormat:=False, ReplaceFormat:=False
'LookAt:= xlPart
Next x

Answer 1

这是一种方法，您首先收集所有感兴趣的标题，根据搜索词分组。
然后根据数字后缀(如果有)对每个术语的单元格进行排序，并重新标记已排序集合中的第一项。

Sub RelabelHeaders()

    Dim fndList As Variant
    Dim c As Range, e
    Dim dict, k, arr, tmp, col As Collection
    Set dict = CreateObject("scripting.dictionary")
    
    fndList = Array("name", "date", "place")
    
    'collect all candidate headers: one collection per search term
    For Each c In Worksheets("Header").Rows(1).SpecialCells(xlCellTypeConstants)
        For Each e In fndList
            'exact match or match+digit[s] (assumes one digit is followed by nothing or by other digits..)
            If c.Value = e Or c.Value Like e & "#*" Then
                If Not dict.exists(e) Then Set dict(e) = New Collection
                dict(e).Add c
                Exit For
            End If
        Next e
    Next c
    
    'loop keys, sort collection and relabel
    For Each k In dict
        Set col = dict(k)
        SortCells col, k
        col(1).Value = "Transfer." & k
        If col.Count > 1 Then col(2).Value = "Sender." & k
    Next k
End Sub

'sort a collection of cells ascending, according to the numeric part(if any)
' remaining after removing `root` from the value
Sub SortCells(col As Collection, root)
    Dim num As Long, i As Long, j As Long
    Dim Temp As Range, v1, v2
    num = col.Count
    For i = 1 To num - 1
        For j = i + 1 To num
            'compare based on numeric part only
            v1 = NumberOnly(col(i).Value, root)
            v2 = NumberOnly(col(j).Value, root)
            If v1 > v2 Then
                Set Temp = col(j)
                col.Remove j
                col.Add Temp, , i
            End If
        Next j
    Next i
End Sub

'extract number from cell value (return 0 if no numerix suffix)
Function NumberOnly(v, root)
    v = Replace(v, root, "")
    If Len(v) = 0 Then v = 0
    NumberOnly = CLng(v)
End Function