VBA复制指定工作表不存在则新建工作簿出现Subscript out of range错误求解

错误原因定位 #

• 核心错误：工作表存在性判断逻辑错误：你直接使用If Sheets("Draft") = ""判断工作表是否存在，当工作簿中没有名为Draft的工作表时，VBA尝试访问不存在的集合元素，直接触发「下标越界」（即你遇到的Subscript out of range报错），这是最主要的报错原因。
• 多余语句引发的引用混乱：Sheets.Select语句无实际作用，还可能导致后续工作表对象的默认指向不符合预期。
• 潜在变量问题：代码中用到的file1变量未看到赋值逻辑，若未提前正确赋值，访问Workbooks(file1)时也会触发下标越界错误。
• 复制工作表逻辑问题：Sheets("Draft").Copy默认会将工作表复制到新工作簿，但你的代码未明确处理对象引用，可能出现保存对象不符合预期的问题。

修复后可用代码 #

Sub HandleDraftSheet()
    Dim wbSource As Workbook
    Dim sht As Worksheet
    Dim hasDraft As Boolean
    ' 请提前确保path1、saveFolder变量已正确赋值
    Set wbSource = Workbooks.Open(path1)
    
    ' 遍历判断Draft工作表是否存在
    hasDraft = False
    For Each sht In wbSource.Sheets
        If sht.Name = "Draft" Then
            hasDraft = True
            Exit For
        End If
    Next sht
    
    If Not hasDraft Then
        ' 不存在则创建空白工作簿保存
        Set wb = Workbooks.Add
        wb.SaveAs saveFolder & "\D201\D201.xlsx", FileFormat:=51
        wb.Close SaveChanges:=False
    Else
        ' 存在则复制Draft到新工作簿保存
        wbSource.Sheets("Draft").Copy
        ActiveWorkbook.SaveAs saveFolder & "\D201\D201.xlsx", FileFormat:=51
        ActiveWorkbook.Close SaveChanges:=False
    End If
    
    ' 关闭原打开的工作簿
    wbSource.Close SaveChanges:=False
End Sub

额外注意事项 #

• 所有用到的变量如path1、saveFolder需要提前赋值，建议在模块开头加上Option Explicit强制变量声明，避免未定义变量引发的错误。
• 保存路径需要确保saveFolder下的D201文件夹已预先创建，否则会触发路径不存在的报错。

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