Excel中根据某列内容拆分为工作簿

简介：根据A列的内容进行筛选，将筛选出来的数据生成一个新的工作簿(可以放到指定文件夹下)，且工作簿名为筛选内容。

举例：

将上面的内容使用VBA会在当前test1下生成5个工作簿，工作簿名分别为TEST1.xls TEST2.xls TEST3.xls TEST4.xls TEST5.xls。且里面的内容也为筛选出来的内容：

如TEST1.xls内容为：

代码

vbnet 复制代码

Sub 根据A列单元格拆分为多个工作簿()
    Dim ws As Worksheet
    Dim filterRange As Range, dataRange As Range
    Dim folderPath As String
    Dim newWorkbook As Workbook
    Dim filteredData As Range
    Dim filterValue As String
    Dim lastRow As Long
    Dim i As Long
    Dim count As Long ' 计数器，用来记录成功导出的工作簿数
    Dim folderName As String

    ' 获取当前工作表
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 获取A列的最后一行
    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
    
    ' 定义数据范围
    Set dataRange = ws.Range("A1").CurrentRegion ' 包含所有数据（标题行和数据行）
    
    
    '导出来的文件放在test1文件夹下面
    
    ' 获取当前工作簿目录，并设置保存目录为 "test1" 文件夹
    folderPath = ThisWorkbook.Path & "\"
    folderName = "test1" ' 目标文件夹名
    
    
    
    If Dir(folderPath & folderName, vbDirectory) = "" Then
        ' 如果 "test1" 文件夹不存在，则创建它
        MkDir folderPath & folderName
    End If
    
    ' 更新文件夹路径
    folderPath = folderPath & folderName & "\"

    ' 清除之前的筛选（如果有）
    ws.AutoFilterMode = False

    ' 初始化计数器
    count = 0

    ' 遍历A列的每个非空单元格
    For i = 2 To lastRow ' 从A2开始
        filterValue = ws.Cells(i, 1).Value
        
        ' 如果A列单元格为空，则跳出循环
        If filterValue = "" Then Exit For
        
        ' 对A列应用筛选
        dataRange.AutoFilter Field:=1, Criteria1:=filterValue

        ' 获取筛选后的可见数据
        On Error Resume Next
        Set filteredData = ws.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        ' 如果筛选结果存在，进行复制
        If Not filteredData Is Nothing Then
            ' 创建新工作簿
            Set newWorkbook = Application.Workbooks.Add
            Application.DisplayAlerts = False
            newWorkbook.Sheets(1).Name = "Sheet1"
            
            ' 复制筛选后的内容（包括标题行）
            filteredData.Copy Destination:=newWorkbook.Sheets(1).Range("A1")

            ' 保存工作簿，并以当前筛选值命名，保存到 "test1" 文件夹
            newWorkbook.SaveAs folderPath & filterValue & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            newWorkbook.Close SaveChanges:=False
            Application.DisplayAlerts = True

            ' 增加计数器
            count = count + 1
        End If
    Next i

    ' 清除筛选
    ws.AutoFilterMode = False

    ' 显示操作完成提示
    If count > 0 Then
        MsgBox "导出完成！共导出了 " & count & " 个工作簿。", vbInformation
    Else
        MsgBox "没有符合条件的数据！", vbExclamation
    End If
End Sub

注意：

使用VBA操作后是不可进行撤回的！！！

2.由于生成的工作簿的名字是根据筛选内容决定的，所以注意筛选的内容要符合文件的命名，否则会出错，如:筛选的内容是 \\ 这种特殊符号，给工作簿命名的时候会出错。