VBA脚本越界错误及按州拆分保存多工作簿问题求助

我来帮你搞定这个问题！你遇到的Script Out of Range错误，大概率是原代码没正确指定工作表、列索引，或者最后一行计算逻辑有问题，导致程序找不到对应对象。下面是针对你的需求定制的VBA代码，已经帮你避开了这些坑：

Sub SplitWorkbookByState()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim stateCol1 As Integer, stateCol2 As Integer
    Dim cell As Range
    Dim uniqueStates As Collection
    Dim stateName As Variant
    Dim newWB As Workbook
    
    ' 绑定目标工作表，确保不会因为表名变动出错
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    stateCol1 = 5 ' Sheet1的州列是E列（列索引从1开始）
    stateCol2 = 6 ' Sheet2的州列是F列
    
    ' 精准计算每个工作表州列的最后一行（忽略空行）
    lastRow1 = ws1.Cells(ws1.Rows.Count, stateCol1).End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, stateCol2).End(xlUp).Row
    
    ' 收集两个表中所有不重复的州名，避免重复创建工作簿
    Set uniqueStates = New Collection
    On Error Resume Next ' 重复添加时自动跳过错误
    ' 遍历Sheet1的州列
    For Each cell In ws1.Range(ws1.Cells(2, stateCol1), ws1.Cells(lastRow1, stateCol1))
        If Trim(cell.Value) <> "" Then ' 跳过空单元格
            uniqueStates.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    ' 遍历Sheet2的州列
    For Each cell In ws2.Range(ws2.Cells(2, stateCol2), ws2.Cells(lastRow2, stateCol2))
        If Trim(cell.Value) <> "" Then
            uniqueStates.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0 ' 恢复正常错误处理
    
    ' 为每个州创建独立工作簿
    For Each stateName In uniqueStates
        ' 新建空白工作簿
        Set newWB = Workbooks.Add
        ' 处理Sheet1的对应州数据
        With ws1
            .Range("A1").AutoFilter Field:=stateCol1, Criteria1:=stateName
            ' 复制筛选后的可见行到新工作簿的第一个工作表
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy newWB.Sheets(1).Range("A1")
            .AutoFilterMode = False ' 取消筛选，不影响原表
        End With
        
        ' 给新工作簿添加第二个工作表，存放Sheet2的对应州数据
        newWB.Sheets.Add After:=newWB.Sheets(newWB.Sheets.Count)
        With ws2
            .Range("A1").AutoFilter Field:=stateCol2, Criteria1:=stateName
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy newWB.Sheets(2).Range("A1")
            .AutoFilterMode = False
        End With
        
        ' 可选：给新工作簿的工作表重命名，方便识别
        newWB.Sheets(1).Name = "Sheet1_保单数据"
        newWB.Sheets(2).Name = "Sheet2_保单数据"
        
        ' 保存工作簿到当前文件所在目录，文件名用州名
        newWB.SaveAs Filename:=ThisWorkbook.Path & "\" & stateName & ".xlsx"
        newWB.Close SaveChanges:=False ' 关闭新工作簿，无需再次保存
    Next stateName
    
    MsgBox "拆分完成！所有州的工作簿已保存到当前文件目录。"
End Sub

关键修复点（解决你的错误） #

1. 明确工作表绑定：直接用ThisWorkbook.Sheets("Sheet1")指定工作表，避免原代码可能用Sheets(1)但实际表名不符的问题。
2. 精准列索引：把E列设为5、F列设为6，符合Excel列索引从1开始的规则，不会出现列下标越界。
3. 正确计算最后一行：针对每个工作表的州列单独计算最后一行，不会因为其他列的空值导致范围超出有效数据。
4. 空值与重复处理：跳过州列的空单元格，用Collection自动去重，避免创建空的或重复的工作簿。

使用步骤 #

1. 打开你的保单工作簿，按Alt+F11打开VBA编辑器。
2. 右键左侧的工作簿名称 → 插入 → 模块。
3. 把上面的代码粘贴到模块窗口中。
4. 按F5运行代码，或者回到Excel界面，点击「开发工具」→「宏」→ 选择SplitWorkbookByState执行。

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