迭代工作表名称导致VBA复制单元格范围时出现运行时错误9

问题描述 #

• 需求：将「RIG」工作表中DataCopyRange定义的范围单元格复制到新建工作表，新建表名存储在NewestSheet变量中
• 异常：执行复制代码时触发运行时错误9（下标越界），但将NewestSheet替换为「RIG」时复制功能正常，调试显示所有变量值符合预期
• 根源：生成表名的NewDataName函数存在逻辑错误，本该在表名重复时递增末尾数字，却会错误地提前递增序号

相关代码片段 #

主执行代码 #

Sheets("Sampling Report").Visible = True
    Sheets("Sampling Report").Copy After:=Worksheets(Worksheets.Count)
    ActiveWindow.ActiveSheet.Name = NewDataName
    NewestSheet = NewDataName
    
    If rangetop = 0 Then
       errnorangetop = MsgBox("An error occured. Range max = " & rangetop, vbCritical, "Error")
       Exit Sub
    End If
        
    
    'Select area of data to copy
    DataCopyRange = "C17:G" & rangetop
    
    'Copy data from RIG tab - this is the line with the error!
    Worksheets("RIG").Range(DataCopyRange).Copy Worksheets(NewestSheet).Range("A10")

表名生成函数代码 #

Private Function NewDataName() As String
    Dim ws As Worksheet
    Dim i As Long: i = 1
    Dim shtname As String
    Dim shortdate As String
    
    shortdate = Format(Date, "dd-mm-yyyy")
    
    
    Do
        ' Create a worksheet name
        shtname = "Sampling Report " & shortdate & " " & i
        
        ' Check if we already have a worksheet with that name
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(shtname)
        On Error GoTo 0
        
        'If no worksheet with that name then return name
        If ws Is Nothing Then
            NewDataName = shtname
            Exit Do
        Else
            i = i + 1
            Set ws = Nothing
        End If
    Loop
End Function

修复方案 #

1. 优化主执行代码（避免激活依赖，直接操作工作表对象） #

Dim newWs As Worksheet
Sheets("Sampling Report").Visible = True
' 复制工作表并直接获取新表对象，避免依赖ActiveSheet
Set newWs = Sheets("Sampling Report").Copy(After:=Worksheets(Worksheets.Count))
' 先获取合法表名，再赋值给新表
NewestSheet = NewDataName
newWs.Name = NewestSheet

If rangetop = 0 Then
   MsgBox "An error occured. Range max = " & rangetop, vbCritical, "Error"
   Exit Sub
End If

DataCopyRange = "C17:G" & rangetop
' 直接使用新表对象复制，避免通过名称查找导致的下标越界
Worksheets("RIG").Range(DataCopyRange).Copy newWs.Range("A10")

2. 修复NewDataName函数逻辑（确保序号正确递增） #

新增辅助函数检查工作表存在性，让表名生成逻辑更稳定：

Private Function NewDataName() As String
    Dim i As Long
    Dim baseName As String
    Dim shortdate As String
    
    shortdate = Format(Date, "dd-mm-yyyy")
    baseName = "Sampling Report " & shortdate & " "
    i = 1
    
    ' 循环查找第一个未被使用的序号
    Do While True
        Dim shtName As String
        shtName = baseName & i
        If Not WorksheetExists(shtName) Then
            NewDataName = shtName
            Exit Do
        End If
        i = i + 1
    Loop
End Function

' 辅助函数：判断指定名称的工作表是否存在
Private Function WorksheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(sheetName)
    On Error GoTo 0
    WorksheetExists = Not ws Is Nothing
End Function

问题原因说明 #

1. 原主代码依赖ActiveWindow.ActiveSheet命名新表，可能因窗口激活状态异常导致实际表名与NewestSheet变量存储值不一致，进而触发下标越界
2. 原NewDataName函数的工作表存在性检查逻辑依赖On Error Resume Next的错误捕获，若出现意外错误（如工作表保护），可能错误判定表名已存在，导致序号提前递增

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