Excel VBA按40行拆分联系人数据至新工作簿（运行时错误9）求助

我正在尝试将名为ContactsforEmails的主工作表拆分成多个工作簿，每个工作簿包含表头和40行数据（从A2开始，覆盖到I列），新工作簿命名为「EmailList(序号)」，直到A列对应单元格为空。目前已经实现了表头复制、保存新文件和复制第一组40行的功能，但循环逻辑有问题，运行时出现Run-time error 9: Subscript out of range错误，怀疑是DoUntil循环和Offset方法使用不当，求帮忙修正！

我的代码尝试： #

'Copy Header
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Rows("1:1").EntireRow.AutoFit
'Save File As New Name
Dim fpath As String
Dim fcount As Integer
Dim fname As String
Do While Len(Dir(fpath & fname)) <> 0
    fpath = "C:\Users\Path\"
    fcount = fcount + 1
    fname = "EmailList" & fcount & ".xlsx"
Loop
ActiveWorkbook.SaveAs Filename:=fpath & fname
'Copy and Paste 40
Windows("ContactsForEmails.xlsx").Activate
Dim fcopy As Range
Set fcopy = Range("A2:H41")
fcopy.Select
Selection.Copy
Windows(fname).Activate
Range("A2").Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Do Until IsEmpty(fcopy)
    fcopy.Offset(40, 0).Select
    Selection.Copy
    Windows(fname).Activate
    Range("A2").Select
    ActiveSheet.Paste
    ActiveWorkbook.Save
    ActiveWorkbook.Close
Loop
End Sub

问题分析 #

你的错误主要来自几个核心问题：

1. 文件名生成逻辑颠倒：一开始fpath和fname未初始化就调用Dir(fpath & fname)，会导致无效路径判断；而且循环逻辑搞反了，应该先确定固定路径，再递增序号检查文件是否存在。
2. 引用已关闭的工作簿：第一次循环后你关闭了新建的工作簿，后续循环再用Windows(fname).Activate肯定找不到这个窗口，直接触发「下标越界」错误。
3. IsEmpty使用错误：IsEmpty(fcopy)无法正确判断一个单元格区域是否为空，你需要检查区域的第一个单元格（比如fcopy.Cells(1,1)）是否为空才行。
4. 过度依赖Select/Activate：这些方法非常脆弱，只要窗口切换、焦点变化就会出错，最佳实践是直接引用工作表和工作簿对象，完全避免激活操作。

修正后的代码 #

Sub SplitContactsToWorkbooks()
    Dim mainWs As Worksheet
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim fpath As String
    Dim fcount As Integer
    Dim fname As String
    Dim startRow As Long
    Dim endRow As Long
    Dim lastRow As Long
    
    ' 初始化主工作表和保存路径（确保路径末尾带反斜杠）
    Set mainWs = ThisWorkbook.Worksheets("ContactsforEmails")
    fpath = "C:\Users\Path\"
    fcount = 1
    startRow = 2 ' 从第2行开始复制数据
    
    ' 获取A列最后一个非空行的行号
    lastRow = mainWs.Cells(mainWs.Rows.Count, "A").End(xlUp).Row
    
    ' 循环拆分每40行数据
    Do While startRow <= lastRow
        ' 计算当前批次的结束行：最多40行，不超过总数据的最后一行
        endRow = startRow + 39
        If endRow > lastRow Then endRow = lastRow
        
        ' 生成不重复的文件名
        Do
            fname = "EmailList" & fcount & ".xlsx"
            fcount = fcount + 1
        Loop While Len(Dir(fpath & fname)) <> 0
        
        ' 创建新工作簿并获取第一个工作表
        Set newWb = Workbooks.Add
        Set newWs = newWb.Worksheets(1)
        
        ' 复制表头（包含格式和列宽）
        mainWs.Range("A1").CurrentRegion.Rows(1).Copy
        newWs.Range("A1").PasteSpecial xlPasteAll
        newWs.Range("A1").PasteSpecial xlPasteColumnWidths
        newWs.Rows(1).EntireRow.AutoFit
        
        ' 复制当前批次的数据（覆盖到I列，可根据实际需求调整列号）
        mainWs.Range(mainWs.Cells(startRow, "A"), mainWs.Cells(endRow, "I")).Copy
        newWs.Range("A2").PasteSpecial xlPasteAll
        
        ' 保存并关闭新工作簿（关闭覆盖提示）
        Application.DisplayAlerts = False
        newWb.SaveAs Filename:=fpath & fname
        newWb.Close
        Application.DisplayAlerts = True
        
        ' 移动到下一批次的起始行
        startRow = endRow + 1
    Loop
    
    MsgBox "数据拆分完成！", vbInformation
End Sub

关键优化点说明 #

• 对象化操作：用mainWs、newWb、newWs直接绑定对象，彻底抛弃Select/Activate，避免窗口切换导致的各种错误。
• 动态行范围计算：自动获取数据最后一行，每次计算当前批次的结束行，确保最后一批不足40行也能正确处理。
• 可靠的文件名生成：从序号1开始递增，直到找到未被使用的文件名，避免覆盖已有文件。
• 完整的复制逻辑：复制表头时包含列宽和格式，数据复制覆盖到你需求的I列（之前代码是H列，已修正）。

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