Excel VBA跨工作簿多工作表匹配查询报错及功能实现需求

原代码的核心问题 #

1. 未指定工作簿的工作表引用：原代码中Sheets(i)默认指向当前工作簿，但实际需要访问的是已打开的POINT TEST.xlsx，导致对象引用错误。
2. 单元格行号列标参数顺序错误：Cells("A" & Rows.Count)不符合Cells对象的参数规则（正确顺序为Cells(行号, 列标/列号)）。
3. 数据类型不匹配：rpno定义为Long，但如果目标单元格是小数，赋值时会触发类型错误。
4. 冗余且错误的工作表跳过逻辑：判断其他工作簿的工作表是否等于当前工作簿的"Item"表完全多余，且逻辑上不成立。
5. 重复引用导致的效率低下与潜在错误：多次重复写Workbooks("POINT TEST.xlsx").Sheets(i)，既冗余又容易出错。

修正后的代码 #

Sub listout()
    Dim newsheet As Worksheet
    Dim Item As String, cellvalue As String
    Dim fname As String, ftype As String, rpno As Variant ' 修改为Variant适配数值类型
    Dim itemnum As Long, itemcount As Long
    Dim otherbook As Workbook, targetWs As Worksheet
    Dim lastRow As Long, lastColumn As Long
    Dim i As Long, a As Long, b As Long, c As Long
    Dim rown As Long
    
    ' 创建结果工作表
    Set newsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newsheet.Name = "Item"
    newsheet.Range("A1:D1").Value = Array("Item", "Function", "Type", "No.") ' 批量设置表头更高效
    rown = 1
    
    ' 获取待查询项总数
    itemnum = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    
    ' 打开目标工作簿并缓存对象
    Set otherbook = Workbooks.Open("C:\Users\Administrator\Desktop\LongLong\TKS\Test\POINT TEST.xlsx")
    
    ' 遍历待查询项
    For itemcount = 2 To itemnum
        Item = ThisWorkbook.Sheets(1).Range("A" & itemcount).Value
        
        ' 遍历目标工作簿的所有工作表
        For Each targetWs In otherbook.Sheets
            ' 获取当前工作表的有效行和列
            lastRow = targetWs.Cells(Rows.Count, 1).End(xlUp).Row ' 正确的行号获取方式
            lastColumn = targetWs.Cells(2, targetWs.Columns.Count).End(xlToLeft).Column
            
            ' 遍历所有单元格查找匹配项
            For a = 1 To lastColumn
                For b = 1 To lastRow
                    cellvalue = targetWs.Cells(b, a).Value
                    If Item = cellvalue Then
                        ' 遍历当前行的所有列，提取数值型数据
                        For c = 1 To lastColumn
                            With targetWs.Cells(b, c)
                                If IsNumeric(.Value) And Not IsEmpty(.Value) Then
                                    rown = rown + 1
                                    fname = targetWs.Cells(2, c).Value
                                    ftype = targetWs.Cells(1, c).Value
                                    rpno = .Value
                                    
                                    ' 处理空值填充逻辑，增加边界判断
                                    If Len(ftype) = 0 Then
                                        If c > 1 Then
                                            ftype = targetWs.Cells(1, c).End(xlToLeft).Value
                                        Else
                                            ftype = "" ' 避免c=1时xlToLeft越界
                                        End If
                                    End If
                                    If Len(fname) = 0 Then fname = ftype
                                    
                                    ' 写入结果
                                    newsheet.Cells(rown, 1).Value = Item
                                    newsheet.Cells(rown, 2).Value = fname
                                    newsheet.Cells(rown, 3).Value = ftype
                                    newsheet.Cells(rown, 4).Value = rpno
                                End If
                            End With
                        Next c
                    End If
                Next b
            Next a
        Next targetWs
    Next itemcount
    
    ' 关闭目标工作簿
    otherbook.Close SaveChanges:=False
End Sub

关键优化点说明 #

• 缓存工作表对象：使用For Each targetWs In otherbook.Sheets遍历目标工作簿的工作表，避免重复的长路径引用，减少错误概率。
• 修正单元格引用规则：将Cells("A" & Rows.Count)改为Cells(Rows.Count, 1)，符合VBA中Cells对象的参数规范。
• 数据类型兼容：将rpno改为Variant，适配整数、小数等多种数值类型。
• 增加边界判断：处理xlToLeft时判断列号是否大于1，避免越界错误。
• 批量操作优化：表头设置使用Array批量赋值，提升代码简洁性和执行效率。

内容的提问来源于stack exchange，提问作者Ho Long Chan