批量查询序列号开票状态的Excel VBA代码优化需求

需求背景 #

日常需检查序列号是否已开票，系统生成的发票文件统一导出至C:\Serial_Numbers路径，所有发票文件中发票号固定在A列，对应序列号在B列。

现有实现问题 #

通过搜索获取并修改了一段VBA代码，该代码可在指定文件夹及子文件夹中搜索指定字符串，但原代码仅支持手动选择单个序列号查询，结果输出至新工作表。已自行调整代码，实现了在原工作表输出结果并固定搜索目录，但尝试循环处理当前工作表A列所有序列号时，出现大量错误，无法完成批量查询。

现有VBA代码 #

'Dimensioning public variable and declaring the data type
'A Public variable can be accessed from any module, Sub Procedure, Function, or Class within a specific workbook.
Public WS As Worksheet
 
'Name macro and parameters
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
 
'Dimension variables and declare data types
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
 
'Redimension array variable
ReDim Folders(0)
 
'IsMissing returns a Boolean value indicating if an optional Variant parameter has been sent to a procedure.
'Check if FolderPath has not been sent
If IsMissing(Folderpath) Then
 
    'Add a worksheet
    Set WS = Sheets.Add
 
    'Ask for a folder to search.
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        myfolder = .SelectedItems(1) & "\"
    End With
     
    'Ask for a search string.
    Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
     
    'Stop macro if no search string is entered.
    If Str = "" Then Exit Sub
     
    'Save "Search string:" to cell "A1".
    WS.Range("A1") = "Search string:"
 
     'Save variable Str to cell "B1".
    WS.Range("B1") = Str
 
    'Save "Path:" to cell "A2".
    WS.Range("A2") = "Path:"
 
    'Save variable myfolder to cell "B2".
    WS.Range("B2") = myfolder
 
    'Save "Folderpath" to cell "A3".
    WS.Range("A3") = "Folderpath"
 
    'Save "Workbook" to cell "B3".
    WS.Range("B3") = "Workbook"
 
    'Save "Worksheet" to cell "C3".
    WS.Range("C3") = "Worksheet"
 
    'Save "Cell Address" to cell "D3".
    WS.Range("D3") = "Cell Address"
 
    'Save "Link" to cell "E3".
    WS.Range("E3") = "Link"
     
    'Save variable myfolder to variable Folderpath
    Folderpath = myfolder
     
    'Dir returns a String representing the name of a file, directory, or folder that matches a specified pattern or file attribute, or the volume label of a drive.
    Value = Dir(myfolder, &H1F)
 
'Continue here if FolderPath has been sent
Else
 
    'Check if the two last characters in Folderpath is "//".
    If Right(Folderpath, 2) = "\\" Then
 
        'Stop macro
        Exit Sub
    End If
 
    'Dir returns a String representing the name of a file, directory, or folder that matches a specified pattern or file attribute, or the volume label of a drive.
    Value = Dir(Folderpath, &H1F)
End If
 
'Keep iterating until Value is nothing
Do Until Value = ""
 
    'Check if Value is . or ..
    If Value = "." Or Value = ".." Then
 
    'Continue here if Value is not . or ..
    Else
 
        'Check if Folderpath & Value is a folder
        If GetAttr(Folderpath & Value) = 16 Then
 
            'Add folder name to array variable Folders
            Folders(UBound(Folders)) = Value
 
            'Add another container to array variable Folders
            ReDim Preserve Folders(UBound(Folders) + 1)
         
        'Continue here if Value is not a folder
        'Check if the file ends with xls, xlsx, or xlsm
        ElseIf Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
 
            'Enable error handling
            On Error Resume Next
 
            'Check if the workbook is password protected.
            Workbooks.Open fileName:=Folderpath & Value, Password:="zzzzzzzzzzzz"
 
            'Check if an error has occurred
            If Err.Number <> 0 Then
 
                'Write the workbook name and the phrase "Password protected."
                WS.Range("A4").Offset(a, 0).Value = Value
                WS.Range("B4").Offset(a, 0).Value = "Password protected"
 
                'Add 1 to variable 1
                a = a + 1
 
                'Disable error handling
                On Error GoTo 0
 
            'Continue here if an error has not occurred
            Else
 
                'Iterate through all worksheets in the active workbook
                For Each sht In ActiveWorkbook.Worksheets
                        'Expand all groups in a sheet
                    sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
 
                        'Search for cells containing search string and save to variable c
                        Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
 
                        'Check if variable c is not empty
                        If Not c Is Nothing Then
 
                            'Save cell address to variable firstAddress
                            firstAddress = c.Address
 
                            'Do ... Loop While c is not nothing
                            Do
 
                                'Save the row of the last non-empty cell in column A
                                Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row
 
                                'Save folderpath to the first empty cell in column A in worksheet WS
                                WS.Range("A1").Offset(Lrow, 0).Value = Folderpath
 
                                'Save value to the first empty cell in column B in worksheet WS
                                WS.Range("B1").Offset(Lrow, 0).Value = Value
 
                                'Save the worksheet name to  the first empty cell in column C in worksheet WS
                                WS.Range("C1").Offset(Lrow, 0).Value = sht.Name
 
                                'Save cell address to the first empty cell in column D in worksheet WS
                                WS.Range("D1").Offset(Lrow, 0).Value = c.Address
                                'Insert hyperlink
                                WS.Hyperlinks.Add Anchor:=WS.Range("E1").Offset(Lrow, 0), Address:=Folderpath & Value, SubAddress:= _
                                "'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
 
                                'Find next cell containing search string and save to variable c
                                Set c = sht.Cells.FindNext(c)
 
                            'Continue iterate while c is not empty and the cell address is not equal to the first cell address.
                            Loop While Not c Is Nothing And c.Address <> firstAddress
                        End If
 
                'Continue with the next worksheet
                Next sht
            End If
 
            'Close workbook
            Workbooks(Value).Close False
 
            'Disable error handling
            On Error GoTo 0
        End If
    End If
    Value = Dir
Loop
 
'Go through all folder names and
For Each Folder In Folders
 
    'start another instance of macro SearchWKBooksSubFolders (recursive)
    SearchWKBooksSubFolders (Folderpath & Folder & "\")
Next Folder
 
'Resize column widths
Cells.EntireColumn.AutoFit
End Sub

期望效果 #

实现批量循环当前工作表A列所有序列号，在C:\Serial_Numbers文件夹及子文件夹的发票文件中查询对应记录，将结果（发票号、文件路径、链接等）输出至当前工作表的对应行。

修改后的批量查询VBA代码 #

Option Explicit

' 批量查询主程序
Sub BatchSearchSerialNumbers()
    Dim sourceWS As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim serialNum As String
    Dim result As Variant
    
    ' 设置当前工作表为数据源表
    Set sourceWS = ActiveSheet
    ' 获取A列最后一行数据
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历A列所有序列号（从第2行开始，假设第1行是表头）
    For i = 2 To lastRow
        serialNum = Trim(sourceWS.Cells(i, "A").Value)
        If serialNum <> "" Then
            ' 调用搜索函数，返回结果数组(发票号, 文件路径, 链接标记, 单元格地址)
            result = SearchSerialInInvoices(serialNum)
            
            ' 将结果写入对应行的B、C、D列
            sourceWS.Cells(i, "B").Value = result(0) ' 发票号
            sourceWS.Cells(i, "C").Value = result(1) ' 文件路径
            If result(2) <> "" Then
                ' 添加超链接
                sourceWS.Hyperlinks.Add Anchor:=sourceWS.Cells(i, "D"), _
                    Address:=result(1), _
                    SubAddress:=result(3), _
                    TextToDisplay:="查看发票"
            End If
        End If
    Next i
    
    ' 自动调整列宽
    sourceWS.Cells.EntireColumn.AutoFit
    MsgBox "批量查询完成！"
End Sub

' 搜索单个序列号在发票文件中的记录
Function SearchSerialInInvoices(serialNum As String) As Variant
    Dim basePath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim foundCell As Range
    Dim invoiceNum As String
    Dim filePath As String
    Dim cellAddr As String
    
    ' 初始化返回值
    invoiceNum = "未找到"
    filePath = ""
    cellAddr = ""
    
    basePath = "C:\Serial_Numbers\"
    fileName = Dir(basePath & "*.xls*") ' 匹配所有Excel格式文件
    
    Do While fileName <> ""
        On Error Resume Next
        ' 打开文件（尝试默认密码，可根据实际修改）
        Set wb = Workbooks.Open(basePath & fileName, Password:="zzzzzzzzzzzz", ReadOnly:=True)
        On Error GoTo 0
        
        If Not wb Is Nothing Then
            For Each ws In wb.Worksheets
                ' 在B列搜索序列号（精确匹配）
                Set foundCell = ws.Columns("B").Find(What:=serialNum, LookIn:=xlValues, LookAt:=xlWhole)
                If Not foundCell Is Nothing Then
                    ' 获取对应A列的发票号
                    invoiceNum = ws.Cells(foundCell.Row, "A").Value
                    filePath = basePath & fileName
                    cellAddr = "'" & ws.Name & "'!" & foundCell.Address
                    Exit For ' 找到后退出工作表循环
                End If
            Next ws
            wb.Close SaveChanges:=False
            Set wb = Nothing
            Exit Do ' 找到后退出文件循环
        End If
        
        fileName = Dir()
    Loop
    
    ' 递归搜索子文件夹
    SearchSubFolders basePath, serialNum, invoiceNum, filePath, cellAddr
    
    ' 返回结果数组
    SearchSerialInInvoices = Array(invoiceNum, filePath, IIf(filePath <> "", "有链接", ""), cellAddr)
End Function

' 递归搜索子文件夹
Sub SearchSubFolders(folderPath As String, serialNum As String, ByRef invoiceNum As String, ByRef filePath As String, ByRef cellAddr As String)
    Dim subFolder As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim foundCell As Range
    
    ' 跳过已找到的情况
    If invoiceNum <> "未找到" Then Exit Sub
    
    subFolder = Dir(folderPath, vbDirectory)
    Do While subFolder <> ""
        If subFolder <> "." And subFolder <> ".." Then
            If (GetAttr(folderPath & subFolder) And vbDirectory) = vbDirectory Then
                ' 搜索当前子文件夹的文件
                Dim fileName As String
                fileName = Dir(folderPath & subFolder & "\*.xls*")
                Do While fileName <> ""
                    On Error Resume Next
                    Set wb = Workbooks.Open(folderPath & subFolder & "\" & fileName, Password:="zzzzzzzzzzzz", ReadOnly:=True)
                    On Error GoTo 0
                    
                    If Not wb Is Nothing Then
                        For Each ws In wb.Worksheets
                            Set foundCell = ws.Columns("B").Find(What:=serialNum, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not foundCell Is Nothing Then
                                invoiceNum = ws.Cells(foundCell.Row, "A").Value
                                filePath = folderPath & subFolder & "\" & fileName
                                cellAddr = "'" & ws.Name & "'!" & foundCell.Address
                                wb.Close SaveChanges:=False
                                Set wb = Nothing
                                Exit Do
                            End If
                        Next ws
                        If Not wb Is Nothing Then wb.Close SaveChanges:=False
                    End If
                    fileName = Dir()
                Loop
                
                ' 递归搜索下一级子文件夹
                SearchSubFolders folderPath & subFolder & "\", serialNum, invoiceNum, filePath, cellAddr
                If invoiceNum <> "未找到" Then Exit Sub
            End If
        End If
        subFolder = Dir()
    Loop
End Sub

代码说明 #

1. 批量处理逻辑：主程序BatchSearchSerialNumbers遍历当前工作表A列所有非空单元格，逐个调用搜索函数。
2. 精准搜索：SearchSerialInInvoices仅在发票文件的B列（序列号列）进行精确匹配，找到后直接返回对应A列的发票号及文件信息。
3. 递归子文件夹：SearchSubFolders处理子文件夹的搜索，确保所有层级的发票文件都被覆盖。
4. 结果输出：将发票号写入对应行B列，文件路径写入C列，超链接写入D列，未找到则显示"未找到"。

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