求开发VBA函数：实现boardtype精确匹配与subsysnum部分匹配

需要开发VBA函数GetClock，接收boardtype（需精确匹配）、subsysnum、column三个参数，在LookupTable.xlsx的Clock工作表中执行如下查找逻辑：

• 找到所有boardtype精确匹配的行；
• 检查subsysnum是否能部分匹配该行的Subsystem列值，若找到则返回对应行指定column的值；
• 若未找到匹配的subsysnum，返回boardtype对应Subsystem列为空的行的指定column的值。

测试示例：

• 当boardtype=AX-6、subsysnum=WD1234TEST时，需返回行索引9对应列的值；
• 当subsysnum=WD298588 trial时返回行8的值；
• 无匹配subsysnum时返回行7的值。

现有代码无法正确获取返回值，附现有代码及参考数据表格如下：

初始尝试代码 #

Function GetClock(boardtype As String, subsysnum As String, column As Long, Optional partialFirst As Boolean = False) As Variant  
    Dim wbSrc As Workbook, ws As Worksheet, r1 As Range, r2 As Range, board_range As Range, firstAddress As String
    FunctionName = "GetClock"
    Set wbSrc = Workbooks.Open("C:\Documents\LookupTable.xlsx")
    Set ws = wbSrc.Worksheets("Clock")

    Set r1 = ws.Columns(1)
    Set r2 = ws.Columns(2)

With r1
        Set board_range = r1.Find(What:=boardtype, LookAt:=xlWhole, LookIn:=xlFormulas, MatchCase:=True) ' find board type row
            If Not board_range Is Nothing Then
                firstAddress = board_range.Address ' save board type address
            Else
                    ErrorMsg = ErrorMsg & IIf(ErrorMsg = "", "", "") & SectionName & ": " & "Board " & boardtype & " could not be found in lookup table" & vbNewLine
                Exit Function
            End If
        Do While Not board_range Is Nothing 
            Set subsysnum_range = r2.Find(What:=subsysnum, LookIn:=xlFormulas, LookAt:=IIf(partialFirst, xlPart, xlWhole), MatchCase:=True)
                    GetClock = ws.cells(board_range.row, column).value
            Exit Function 

        Set board_range = r1.Find(boardtype, board_range)
            If board_range.Address = firstAddress Then
                GetClock = ws.cells(Range(firstAddress).row, column).value 
                If GetClock = 0 Then
                    ErrorMsg = ErrorMsg & IIf(ErrorMsg = "", "", "") & SectionName & ": " & "lookup table missing value" & vbNewLine
                End If
                Exit Function
            End If
     Loop
End With
End Function

更新后代码（Column(13)为Data Sheet中存储subsysnum的列） #

Function GetClock(boardtype As String, subsysnum As String, column As Long, Optional partialFirst As Boolean = False) As Double  
Dim wbSrc As Workbook, ws As Worksheet, r1 As Range, r2 As Range, board_range As Range, firstAddress As String, subsysnum_range As Range, rng_board As Range, rng_subsys As Range
FunctionName = "GetExternalClock"
Set wbSrc = Workbooks.Open("C:\Documents\LookupTable.xlsx")
Set ws = wbSrc.Worksheets("Clock")

Dim wb As Workbook, dataws As Worksheet
Set wb = Workbooks("S93.xlsm")
Set dataws = wb.Worksheets("Data Sheet")
Set r1 = ws.Columns(1)
Set r2 = ws.Columns(2)

With r1
    Set board_range = r1.Find(What:=boardtype, LookAt:=xlWhole, LookIn:=xlFormulas, MatchCase:=True) ' find board type row
        If Not board_range Is Nothing Then
            firstAddress = board_range.Address ' save board type address
        Else
                ErrorMsg = ErrorMsg & IIf(ErrorMsg = "", "", "") & SectionName & ": " & "Board " & boardtype & " could not be found in lookup table" & vbNewLine
            Exit Function
        End If
Dim subsys As Range, cell As String
    Do While Not board_range Is Nothing ' while board type is not nothing look for value of cell in column 2
        For Each subsys In Range("B3:B12")
            cell = subsys.value
            Set subsys_rng = dataws.Columns(13).Find(What:=cell, LookIn:=xlFormulas, LookAt:=IIf(partialFirst, xlPart, xlWhole), MatchCase:=True)
            If cell = "" Then
            GoTo Skip
            Else
                GetClock= ws.cells(subsys_rng.row, column).value
            End If
 
 Skip:
    Next subsys
    Exit Function

     'if intersect.value does not equal sysnum, then it will set board_range below only after it has checked every matching cell in column 1
    Set board_range = r1.Find(boardtype, board_range)
        If board_range.Address = firstAddress Then
            GetClock= ws.cells(Range(firstAddress).row, column).value ' boardtype row index with empty cell in r2
            If GetClock= 0 Then
                ErrorMsg = ErrorMsg & IIf(ErrorMsg = "", "", "") & SectionName & ": " & "lookup table missing value" & vbNewLine
            End If
            Exit Function
        End If
    Loop
End With
Exit Function
End Function

参考数据表格 #

修复后的GetClock函数 #

Function GetClock(boardtype As String, subsysnum As String, column As Long) As Variant
    Dim wbSrc As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim matchFound As Boolean
    Dim defaultVal As Variant
    
    ' 初始化返回值为错误
    GetClock = CVErr(xlErrNA)
    
    ' 处理工作簿打开逻辑（避免重复打开）
    On Error Resume Next
    Set wbSrc = Workbooks("LookupTable.xlsx")
    On Error GoTo 0
    If wbSrc Is Nothing Then
        Set wbSrc = Workbooks.Open("C:\Documents\LookupTable.xlsx")
    End If
    
    Set ws = wbSrc.Worksheets("Clock")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    matchFound = False
    defaultVal = Empty
    
    ' 遍历行执行查找逻辑
    For i = 2 To lastRow ' 假设第1行为表头
        If ws.Cells(i, 1).Value = boardtype Then
            ' 记录Subsystem为空的默认值
            If Trim(ws.Cells(i, 2).Value) = "" Then
                defaultVal = ws.Cells(i, column).Value
            End If
            
            ' 检查subsysnum是否部分匹配当前Subsystem值
            If Trim(ws.Cells(i, 2).Value) <> "" And InStr(1, subsysnum, ws.Cells(i, 2).Value, vbTextCompare) > 0 Then
                GetClock = ws.Cells(i, column).Value
                matchFound = True
                Exit For
            End If
        End If
    Next i
    
    ' 未找到匹配时返回默认值
    If Not matchFound Then
        If IsEmpty(defaultVal) Then
            GetClock = CVErr(xlErrNA)
        Else
            GetClock = defaultVal
        End If
    End If
    
    ' 关闭工作簿（仅关闭我们打开的实例）
    If wbSrc.Name = "LookupTable.xlsx" And Not wbSrc.Saved Then
        wbSrc.Close SaveChanges:=False
    End If
    
End Function

代码说明 #

1. 工作簿管理：先检查工作簿是否已打开，避免重复打开导致文件锁定；使用后自动关闭（未修改则不保存）；
2. 逻辑匹配：严格遵循需求，先收集boardtype匹配且Subsystem为空的默认值，再检查部分匹配的Subsystem项；
3. 匹配规则：用InStr实现不区分大小写的部分匹配，如需区分可改为vbBinaryCompare；
4. 错误处理：初始化返回值为#N/A，无匹配且无默认值时保持错误状态，符合Excel函数的错误返回规范；
5. 性能优化：遍历范围限定在有效数据行内，避免无效循环。

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