VBA技巧| 批量按照指定列条件拆分数据为单独工作簿.xlsm

Sub SplitDataByColumn()    Dim ws As Worksheet    Dim rng As Range    Dim dict As Object    Dim key As Variant    Dim colIndex As Integer    Dim lastRow As Long, lastCol As Long    Dim headerRow As Range    Dim newWb As Workbook    Dim filterValue As String    Dim savePath As String
    ' 注意：这里需要根据你的实际工作表名称调整，小编的工作表名称是订单    Set ws = sheets("订单")
    ' 获取用户选择的列    On Error Resume Next    colIndex = Application.InputBox("请输入要拆分的列号（数字）:", "选择列", Type:=1)    On Error GoTo 0
    If colIndex = 0 Then Exit Sub ' 用户取消
    ' 获取数据范围    lastRow = ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column    Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))    Set headerRow = rng.Rows(1)
    ' 创建字典用于存储唯一值    Set dict = CreateObject("Scripting.Dictionary")
    ' 收集唯一值（从第2行开始，跳过标题）    For i = 2 To lastRow        filterValue = ws.Cells(i, colIndex).Value        If Not dict.exists(filterValue) Then            dict.Add filterValue, 1        End If    Next i
    ' 设置保存路径    savePath = Application.GetSaveAsFilename(InitialFileName:="拆分数据", _                  FileFilter:="Excel Files (*.xlsx), *.xlsx", _                  Title:="选择保存位置和文件名")
    If savePath = "False" Then Exit Sub ' 用户取消
    ' 提取路径部分（不包括文件名）    savePath = Left(savePath, InStrRev(savePath, "\"))
    ' 关闭屏幕更新以提高性能    Application.ScreenUpdating = False
    ' 遍历字典中的每个键（唯一值）    For Each key In dict.keys        ' 筛选数据        rng.AutoFilter Field:=colIndex, Criteria1:=key
        ' 创建新工作簿        Set newWb = Workbooks.Add
        ' 复制标题行        headerRow.SpecialCells(xlCellTypeVisible).Copy newWb.Sheets(1).Range("A1")
        ' 复制可见数据（不包括标题）        ws.Range("A2:A" & lastRow).Resize(, lastCol).SpecialCells(xlCellTypeVisible).Copy _           newWb.Sheets(1).Range("A2")
        ' 移除筛选        ws.AutoFilterMode = False
        ' 清理文件名中的非法字符        Dim safeFileName As String        safeFileName = CleanFileName(key)
        ' 保存工作簿        On Error Resume Next ' 防止文件名错误导致崩溃        newWb.SaveAs savePath & safeFileName & ".xlsx"        On Error GoTo 0
        ' 关闭工作簿        newWb.Close False    Next key
    ' 恢复屏幕更新    Application.ScreenUpdating = True
    MsgBox "数据拆分完成！共创建 " & dict.Count & " 个工作簿。", vbInformationEnd Sub
Function CleanFileName(ByVal fileName As String) As String    ' 替换文件名中的非法字符    Dim illegalChars As String    illegalChars = "\/:*?""<>|"
    Dim i As Integer    For i = 1 To Len(illegalChars)        fileName = Replace(fileName, Mid(illegalChars, i, 1), "_")    Next i
    ' 限制文件名长度（Windows限制为255字符，这里设为50）    If Len(fileName) > 50 Then        fileName = Left(fileName, 50)    End If
    CleanFileName = fileNameEnd Function