Excel多工作表跨表数据提取：VBA代码1004错误及Dictionary应用咨询

问题概述 #

需要在Excel工作簿的多个工作表中搜索指定值（如B-0-1），找到匹配项后，检查该单元格所在行左侧的其他列单元格：若单元格为数值型，则提取该列的表头值（第1行）、二级表头值（第2行）、单元格数值，连同目标值一起写入新工作表。当前代码仅能创建新工作表并生成首行表头，但运行时触发1004应用程序定义或对象定义错误，询问是否需要使用Dictionary解决。

现有代码 #

Sub listout()
Dim ws As Worksheet
Dim Item As String
Dim Totalsheets As Integer

'Item name
Item = "B-0-1"
Totalsheets = Worksheets.Count
Dim newsheet As Worksheet

Set newsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(Totalsheets))
newsheet.Name = Item
newsheet.Range("A1").Value = "Item"
newsheet.Range("B1").Value = "Function"
newsheet.Range("C1").Value = "Type"
newsheet.Range("D1").Value = "No."

Dim rown As Integer
rown = 1

For i = 1 To Totalsheets
lastRow = Sheets(i).Range("A" & Rows.Count).End(xlUp).Row
lastColumn = Sheets(i).Range(1, Columns.Count).End(xlToLeft).Column
For a = 1 To lastColumn
For b = 1 To lastRow
cellvalue = Sheets(i).Cells(b, a).Value
If Item = cellvalue Then

For c = 1 To lastColumn
If IsNumeric(Sheets(i).Range(b, c)) = True Then
rown = rown + 1
fname = Sheets(i).Cells(2, c).Value
ftype = Sheets(i).Cells(1, c).Value
rpno = Sheets(i).Cells(b, c).Value
newsheet.Range("A" & rown).Value = Item
newsheet.Range("B" & rown).Value = fname
newsheet.Range("C" & rown).Value = ftype
newsheet.Range("D" & rown).Value = rpno
End If
Next c
End If
Next b
Next a
Next i
End Sub

错误原因分析 #

1. Range对象用法错误：代码中IsNumeric(Sheets(i).Range(b, c))是错误的，Range的双参数语法是Range(Cell1, Cell2)，而非行号+列号。判断单元格数值类型应使用Cells(b, c)，即IsNumeric(Sheets(i).Cells(b, c))，这是触发1004错误的核心原因。
2. 逻辑不符合需求：原需求是检查匹配单元格左侧的列，但代码遍历了整行所有列（c = 1 To lastColumn），应改为遍历c = 1 To a - 1（a是匹配单元格的列号）。
3. 变量未显式声明：lastRow、lastColumn、i、a等变量未声明，默认是变体类型，易引发未知错误。
4. 未处理重复工作表：若已存在同名工作表，Sheets.Add会直接报错。

是否需要使用Dictionary？ #

当前问题的核心是代码语法错误和逻辑偏差，不需要使用Dictionary。Dictionary主要用于键值对存储、去重或高效查找场景，而当前需求用基础循环即可实现，先修复代码错误即可解决问题。

修复后的代码 #

Option Explicit '强制变量声明，避免隐式错误

Sub listout()
    Dim ws As Worksheet
    Dim Item As String
    Dim TotalSheets As Integer
    Dim newSheet 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
    Dim cellValue As Variant
    Dim fname As String, ftype As String, rpno As Variant
    
    '目标搜索值
    Item = "B-0-1"
    TotalSheets = ThisWorkbook.Worksheets.Count
    rown = 1
    
    '检查并创建新工作表（避免重复）
    On Error Resume Next
    Set newSheet = ThisWorkbook.Worksheets(Item)
    On Error GoTo 0
    If newSheet Is Nothing Then
        Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(TotalSheets))
        newSheet.Name = Item
        '写入表头
        newSheet.Range("A1:D1").Value = Array("Item", "Function", "Type", "No.")
    Else
        '清空已有数据（保留表头）
        newSheet.Range("A2:D" & newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row).ClearContents
        rown = 1
    End If
    
    '遍历所有工作表
    For i = 1 To TotalSheets
        Set ws = ThisWorkbook.Worksheets(i)
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        
        '遍历行和列，查找目标值
        For b = 1 To lastRow
            For a = 1 To lastColumn
                cellValue = ws.Cells(b, a).Value
                If cellValue = Item Then
                    '遍历匹配单元格左侧的列（c从1到a-1）
                    For c = 1 To a - 1
                        '判断是否为数值型（排除空单元格）
                        If IsNumeric(ws.Cells(b, c)) And ws.Cells(b, c).Value <> "" Then
                            rown = rown + 1
                            fname = ws.Cells(2, c).Value
                            ftype = ws.Cells(1, c).Value
                            rpno = ws.Cells(b, c).Value
                            '写入新工作表
                            newSheet.Cells(rown, "A").Value = Item
                            newSheet.Cells(rown, "B").Value = fname
                            newSheet.Cells(rown, "C").Value = ftype
                            newSheet.Cells(rown, "D").Value = rpno
                        End If
                    Next c
                End If
            Next a
        Next b
    Next i
End Sub

修复说明 #

• 新增Option Explicit强制变量声明，避免隐式错误。
• 修复Range为Cells的用法，解决1004错误。
• 调整循环逻辑，仅遍历匹配单元格左侧的列，符合需求。
• 添加了重复工作表检查，避免创建同名表报错；若已存在则清空旧数据重新写入。
• 优化变量类型为Long（避免行号超过Integer上限），同时排除空单元格的数值判断。

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