Excel拆分成多个工作簿vba代码

以下是一个示例的VBA代码，用于将Excel工作簿拆分成多个工作簿：

Sub SplitWorkbook()
    Dim OriginalWorkbook As Workbook
    Dim NewWorkbook As Workbook
    Dim OriginalWorksheet As Worksheet
    Dim NewWorksheet As Worksheet
    Dim Cell As Range
    Dim RowCounter As Long
    Dim LastRow As Long
    Dim SplitColumn As Range
    Dim UniqueValues As Collection
    Dim Value As Variant
    
    ' 设置原始工作簿和工作表
    Set OriginalWorkbook = ThisWorkbook
    Set OriginalWorksheet = OriginalWorkbook.Worksheets("Sheet1") ' 替换为您要拆分的工作表名称
    
    ' 设置拆分列范围
    Set SplitColumn = OriginalWorksheet.Range("A:A") ' 替换为您要拆分的列
    
    ' 获取唯一值集合
    Set UniqueValues = New Collection
    On Error Resume Next
    For Each Cell In SplitColumn
        UniqueValues.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    
    ' 遍历唯一值并创建新工作簿
    For Each Value In UniqueValues
        ' 创建新工作簿并复制原始工作表的结构和数据
        Set NewWorkbook = Workbooks.Add
        Set NewWorksheet = NewWorkbook.Worksheets(1)
        OriginalWorksheet.Copy Before:=NewWorksheet
        
        ' 删除除唯一值之外的行
        With NewWorksheet
            LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            For RowCounter = LastRow To 2 Step -1 ' 从最后一行开始往上遍历
                If .Cells(RowCounter, 1).Value <> Value Then
                    .Rows(RowCounter).Delete
                End If
            Next RowCounter
        End With
        
        ' 保存新工作簿
        NewWorkbook.SaveAs "路径\" & Value & ".xlsx" ' 替换为您要保存的路径和文件名
        
        ' 关闭新工作簿
        NewWorkbook.Close SaveChanges:=False
    Next Value
End Sub

请注意，您需要根据实际情况进行以下修改：

1. 将`"Sheet1"`替换为您要拆分的工作表名称。
2. 将`"A:A"`替换为您要拆分的列范围。
3. 将`"路径\" & Value & ".xlsx"`替换为您要保存的路径和文件名。

运行此代码后，它将根据指定的列中的唯一值，将原始工作簿拆分为多个新的工作簿，并将每个唯一值命名为文件名。每个新工作簿将只包含与对应唯一值匹配的行。