编写VBA函数基于18位型号匹配正确装配组件的需求

需求说明 #

• 功能目标：基于18位型号编号，从多个工作表（每个工作表对应一个装配族）中筛选符合条件的装配组件
• 判定规则：
  • 若组件匹配规则对应的单元格为空，默认判定为TRU（符合条件）
  • 每个工作表仅返回一个匹配项
• 优化方向：替代现有手动维护的复杂Excel公式，实现无需硬编码位数的递归匹配函数，降低维护成本

现有手动公式 #

=IF(AND(MID(Test!$S$2,1,2)=B61,
        OR(MID(Test!$S$2,3,1)=MID(C61,1,1),
           MID(Test!$S$2,3,1)=MID(C61,3,1),C61=""),
           MID(Test!$S$2,4,2)=D61,
           OR(MID(Test!$S$2,7,1)=MID(E61,1,1),
              MID(Test!$S$2,7,1)=MID(E61,3,1),E61=""),
        OR(MID(Test!$S$2,14,1)=MID(F61,1,1),
           MID(Test!$S$2,14,1)=MID(F61,3,1),
           MID(Test!$S$2,14,1)=MID(F61,5,1),
           MID(Test!$S$2,14,1)=MID(F61,7,1)),
        OR(MID(Test!$S$2,17,1)=G61,G61="")),"TRU","F")

VBA递归函数实现 #

核心思路 #

1. 将型号的匹配规则（起始位置、长度、匹配方式）抽象为可配置数组，避免硬编码位数
2. 递归遍历每个规则，逐一验证型号与组件的匹配性
3. 遍历目标工作表，每个表返回第一个匹配的组件

代码实现 #

Function FindMatchingComponent(targetModel As String, Optional sheetNames As Variant = Empty) As String
    Dim ws As Worksheet
    Dim matchRules As Variant
    Dim result As String
    
    ' 定义匹配规则：每一项为(型号起始位, 型号长度, 组件列号, 匹配类型)
    ' 匹配类型：1=完全匹配；2=间隔1取字符匹配；3=间隔2取字符匹配
    matchRules = Array( _
        Array(1, 2, "B", 1), _
        Array(3, 1, "C", 2), _
        Array(4, 2, "D", 1), _
        Array(7, 1, "E", 2), _
        Array(14, 1, "F", 3), _
        Array(17, 1, "G", 1) _
    )
    
    ' 处理遍历范围：默认所有工作表，可指定目标表
    If IsEmpty(sheetNames) Then
        For Each ws In ThisWorkbook.Worksheets
            result = CheckComponentMatch(ws, targetModel, matchRules, LBound(matchRules))
            If result <> "" Then
                FindMatchingComponent = result & "（来自工作表：" & ws.Name & "）"
                Exit Function
            End If
        Next ws
    Else
        Dim sheetName As Variant
        For Each sheetName In sheetNames
            Set ws = ThisWorkbook.Worksheets(sheetName)
            result = CheckComponentMatch(ws, targetModel, matchRules, LBound(matchRules))
            If result <> "" Then
                FindMatchingComponent = result & "（来自工作表：" & ws.Name & "）"
                Exit Function
            End If
        Next sheetName
    End If
    
    ' 无匹配项时返回空
    FindMatchingComponent = ""
End Function

Private Function CheckComponentMatch(ws As Worksheet, targetModel As String, rules As Variant, currentRuleIndex As Integer) As String
    Dim currentRule As Variant
    Dim modelSegment As String
    Dim componentValue As String
    Dim row As Integer
    Dim isMatch As Boolean
    
    ' 递归终止：所有规则验证完成，返回当前行组件名称（假设A列为组件标识）
    If currentRuleIndex > UBound(rules) Then
        CheckComponentMatch = ws.Cells(row, "A").Value
        Exit Function
    End If
    
    currentRule = rules(currentRuleIndex)
    Dim startPos As Integer: startPos = currentRule(0)
    Dim lenSegment As Integer: lenSegment = currentRule(1)
    Dim col As String: col = currentRule(2)
    Dim matchType As Integer: matchType = currentRule(3)
    
    ' 遍历数据行（假设第1行为表头，数据从第2行开始）
    For row = 2 To ws.Cells(ws.Rows.Count, col).End(xlUp).row
        componentValue = Trim(ws.Cells(row, col).Value)
        
        ' 单元格为空，默认符合条件，递归验证下一个规则
        If componentValue = "" Then
            CheckComponentMatch = CheckComponentMatch(ws, targetModel, rules, currentRuleIndex + 1)
            If CheckComponentMatch <> "" Then Exit Function
        Else
            modelSegment = Mid(targetModel, startPos, lenSegment)
            isMatch = False
            
            Select Case matchType
                Case 1 ' 完全匹配
                    isMatch = (modelSegment = componentValue)
                Case 2, 3 ' 间隔取字符匹配
                    Dim i As Integer
                    For i = 1 To Len(componentValue) Step 2
                        If modelSegment = Mid(componentValue, i, lenSegment) Then
                            isMatch = True
                            Exit For
                        End If
                    Next i
            End Select
            
            ' 当前规则匹配，递归验证下一个规则
            If isMatch Then
                CheckComponentMatch = CheckComponentMatch(ws, targetModel, rules, currentRuleIndex + 1)
                If CheckComponentMatch <> "" Then Exit Function
            End If
        End If
    Next row
    
    ' 当前行无匹配，返回空
    CheckComponentMatch = ""
End Function

使用说明 #

1. 打开Excel，按Alt+F11打开VBA编辑器
2. 插入模块，粘贴上述代码
3. 在工作表单元格中调用函数：
   • 遍历所有工作表：=FindMatchingComponent(S2)（S2为18位型号所在单元格）
   • 指定目标工作表：=FindMatchingComponent(S2, {"Sheet1","Sheet2"})

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