如何为VBA .Find查找逻辑新增第三个origin判断条件

核心修改逻辑：将原CopyRows子程序仅支持2种状态的布尔型入参，替换为直接传入origin类型字符串，可灵活支持3种及以上匹配规则，后续新增origin类型也无需重构参数结构。

具体修改步骤 #

• 调整Export子程序的origin判断分支，新增Name类型的调用逻辑
• 修改CopyRows的入参定义，替换原布尔型PartialString参数为字符串类型的OriginType参数
• 在CopyRows内部新增Name类型对应的匹配规则、单元格偏移逻辑，你可以根据实际业务需求调整匹配规则（精确/模糊）和偏移量数值

修改后完整代码 #

Private aCell As Range
Dim wsImport As Worksheet
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim wsSpec As Worksheet
Sub Export()
  
    Set wsImport = ThisWorkbook.Sheets("Import")
    Set wsInput = ThisWorkbook.Sheets("Input")
    Set wsSpec = ThisWorkbook.Sheets("Specifications")
    Set wsOutput = ThisWorkbook.Sheets("Output")
    
    Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
    Dim origin As String, KeytoFind As String, strAdress As String
    Dim rngDB As Range
    Dim LastRowImport As Long, LastRowOutput As Long
    Dim i As Integer
         
        CriteriaA = wsInput.Range("F4").Value2
        CriteriaB = wsInput.Range("F5").Value2
        CriteriaC = wsInput.Range("F6").Value2
        
        Set rngDB = wsSpec.Range("h1", wsSpec.Range("h" & Rows.Count).End(xlUp))
        Set aCell = rngDB.Find(What:=CriteriaA, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
       
        If Not aCell Is Nothing Then
            strAdress = aCell.Address
            Do
                If aCell.Offset(, 1).Value2 = CriteriaB And _
                   aCell.Offset(, 2).Value2 = CriteriaC Then
                                                                        
                   origin = aCell.Offset(, 8).Value2
                   KeytoFind = aCell.Offset(, 9).Value2
                   
                   If origin = "Variabele" Then
                        CopyRows "C", KeytoFind, "Variabele"
                   ElseIf origin = "Rekening" Then
                        CopyRows "D", KeytoFind, "Rekening"
                   ElseIf origin = "Name" Then
                        ' 匹配列改为B列，传入origin类型为Name
                        CopyRows "B", KeytoFind, "Name"
                   End If
                End If
            Set aCell = rngDB.FindNext(aCell)
            Loop While aCell.Address <> strAdress
        End If
End Sub
' 入参修改：将原布尔型PartialString替换为OriginType字符串
Private Sub CopyRows(Col As String, Searchstring As String, OriginType As String)
    Dim copyFrom As Range, copyFromDatum As Range, copyFromDesc As Range, copyFromAmount As Range, copyFromVar As Range
    Dim lRow As Long, LastRow As Long
     
    LastRow = wsOutput.Cells(Rows.Count, 9).End(xlUp).Row
    
    With wsImport
        .AutoFilterMode = False
        lRow = .Range(Col & .Rows.Count).End(xlUp).Row
        With .Range(Col & "1:" & Col & lRow)
            Select Case OriginType
                Case "Rekening"
                    ' Rekening逻辑：精确匹配
                    .AutoFilter Field:=1, Criteria1:=Searchstring
                    ' Key
                    Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells
                    ' Datum 偏移-3
                    Set copyFromDatum = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, -3)
                    ' Omschrijving 偏移-2
                    Set copyFromDesc = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, -2)
                    ' Bedrag 偏移+1
                    Set copyFromAmount = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, 1)
                    ' Variabele 偏移-1
                    Set copyFromVar = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, -1)
                Case "Variabele"
                    ' Variabele逻辑：模糊匹配
                    .AutoFilter Field:=1, Criteria1:="=*" & Searchstring & "*"
                    ' Key
                    Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells
                    ' Datum 偏移-2
                    Set copyFromDatum = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, -2)
                    ' Omschrijving 偏移-1
                    Set copyFromDesc = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, -1)
                    ' Bedrag 偏移+2
                    Set copyFromAmount = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, 2)
                    ' Variabele 偏移0
                    Set copyFromVar = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, 0)
                Case "Name"
                    ' 可根据实际需求修改匹配规则：精确匹配用Criteria1:=Searchstring，模糊匹配用Criteria1:="=*" & Searchstring & "*"
                    .AutoFilter Field:=1, Criteria1:="=*" & Searchstring & "*"
                    ' Key
                    Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells
                    ' 以下偏移量可根据Name类型的实际规则修改
                    Set copyFromDatum = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, -1)
                    Set copyFromDesc = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, 1)
                    Set copyFromAmount = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, 2)
                    Set copyFromVar = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells.Offset(0, 3)
            End Select
        End With
        .AutoFilterMode = False
    End With    
End Sub

可选规范优化 #

如果要避免字符串拼写错误导致的逻辑异常，可自定义枚举类型替代字符串传参，示例定义如下（放在模块顶部即可）：

Enum OriginEnum
    Rekening
    Variabele
    Name
End Enum

之后把CopyRows的OriginType参数类型改为OriginEnum，调用时传入OriginEnum.Rekening等枚举值即可。

内容的提问来源于stack exchange，提问作者rockatheman1