使用VBA宏创建工作表失败：Runtime error 9等问题求助

错误根源分析 #

原代码存在以下核心问题引发报错：

• Runtime error 9（下标越界）：NameList数组初始为空，首次调用UBound(NameList)触发错误；若工作表名称并非严格的1994-2022纯数字字符串，Worksheets(CStr(Year))无法定位目标工作表。
• Runtime error 13（类型不匹配）：单元格含错误值（如#N/A、#VALUE!）时，UCase(Sheet.Cells(i,2).Value)会触发类型冲突；Name变量未明确类型，易引发数据类型不兼容问题。
• Runtime error 424（对象要求）：复制行时NewSheet.Cells(Rows.Count,1).End(xlUp).Row.Offset(1)写法错误（Row是数值，无法调用Offset）；ActiveWorkbook因窗口激活状态不稳定，易导致对象引用失效。

修复后的完整代码 #

Function IsInArray(arr As Variant, val As String) As Boolean
    Dim found As Boolean
    found = False
    
    If IsArray(arr) And Not IsEmpty(arr) Then
        Dim i As Long
        For i = LBound(arr) To UBound(arr)
            ' 过滤空字符串，避免无效匹配
            If arr(i) = val And val <> "" Then
                found = True
                Exit For
            End If
        Next i
    End If
    
    IsInArray = found
End Function

Sub Create_Individual_Sheets()
    Dim SheetName As String
    Dim NameList() As String
    Dim LastRow As Long
    Dim Year As Integer
    Dim Sheet As Worksheet
    Dim NewSheet As Worksheet
    Dim currentName As String ' 明确字符串类型，避免类型冲突
    Dim i As Long
    Dim Folder As String
    Dim nextRow As Long ' 存储目标工作表的下一行位置
    
    ' 确保输出文件夹存在，不存在则创建
    Folder = "C:\Users\Jorjao\Desktop\Folder"
    If Dir(Folder, vbDirectory) = "" Then
        MkDir Folder
    End If
    
    ' 初始化数组，避免首次UBound调用报错
    ReDim NameList(0 To 0)
    NameList(0) = ""
    
    For Year = 1994 To 2022
        ' 检查目标年份工作表是否存在
        On Error Resume Next
        Set Sheet = ThisWorkbook.Worksheets(CStr(Year))
        On Error GoTo 0
        If Sheet Is Nothing Then
            MsgBox "未找到工作表：" & Year, vbExclamation
            Set Sheet = Nothing
            Exit For
        End If
        
        LastRow = Sheet.Cells(Sheet.Rows.Count, 1).End(xlUp).Row
        
        ' 遍历姓名列，收集唯一姓名
        For i = 2 To LastRow
            ' 跳过错误值和空单元格
            If Not IsError(Sheet.Cells(i, 2).Value) Then
                currentName = UCase(Trim(Sheet.Cells(i, 2).Value))
                If currentName <> "" And Not IsInArray(NameList, currentName) Then
                    ReDim Preserve NameList(UBound(NameList) + 1)
                    NameList(UBound(NameList)) = currentName
                End If
            End If
        Next i
        Set Sheet = Nothing
    Next Year
    
    ' 遍历姓名列表，创建独立工作表并保存
    For i = 1 To UBound(NameList) ' 从索引1开始，跳过初始空字符串
        currentName = NameList(i)
        SheetName = Replace(currentName, " ", "_")
        ' 替换工作表名称中的非法字符
        SheetName = Replace(SheetName, "/", "-")
        SheetName = Replace(SheetName, "\", "-")
        SheetName = Replace(SheetName, ":", "-")
        SheetName = Replace(SheetName, "*", "-")
        SheetName = Replace(SheetName, "?", "-")
        SheetName = Replace(SheetName, "[", "-")
        SheetName = Replace(SheetName, "]", "-")
        
        ' 创建新工作表
        Set NewSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        NewSheet.Name = SheetName
        
        ' 复制表头到新工作表
        ThisWorkbook.Worksheets(CStr(1994)).Rows(1).Copy Destination:=NewSheet.Rows(1)
        nextRow = 2 ' 表头占第1行，从第2行开始粘贴数据
        
        ' 遍历各年份工作表，复制对应姓名的行
        For Year = 1994 To 2022
            On Error Resume Next
            Set Sheet = ThisWorkbook.Worksheets(CStr(Year))
            On Error GoTo 0
            If Sheet Is Nothing Then
                MsgBox "未找到工作表：" & Year, vbExclamation
                Set Sheet = Nothing
                Exit For
            End If
            
            LastRow = Sheet.Cells(Sheet.Rows.Count, 1).End(xlUp).Row
            For i = 2 To LastRow
                If Not IsError(Sheet.Cells(i, 2).Value) Then
                    If UCase(Trim(Sheet.Cells(i, 2).Value)) = currentName Then
                        Sheet.Rows(i).Copy Destination:=NewSheet.Rows(nextRow)
                        nextRow = nextRow + 1
                    End If
                End If
            Next i
            Set Sheet = Nothing
        Next Year
        
        ' 保存新工作表为独立文件
        NewSheet.Copy
        With ActiveWorkbook
            .SaveAs Filename:=Folder & "\" & SheetName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            .Close SaveChanges:=False
        End With
        ' 删除原工作簿中的临时工作表
        Application.DisplayAlerts = False
        NewSheet.Delete
        Application.DisplayAlerts = True
        Set NewSheet = Nothing
    Next i
    
    MsgBox "所有姓名工作表已生成并保存！", vbInformation
End Sub

关键修改说明 #

1. 数组初始化优化：提前初始化NameList数组并填充空字符串，避免首次UBound调用报错。
2. 工作表存在性校验：增加错误捕获逻辑，检查目标年份工作表是否存在，避免下标越界。
3. 错误值过滤：跳过含错误值的单元格，避免类型不匹配错误。
4. 对象引用规范：明确以ThisWorkbook为操作对象，避免ActiveWorkbook的不确定性；修复复制行时的Offset写法错误。
5. 非法字符处理：替换工作表名称中的非法字符（如/、:等），避免重命名失败。
6. 临时资源清理：生成独立文件后删除原工作簿中的临时工作表，避免文件冗余。

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