【Excel VBA编程】按指定列拆分工作表数据,并保存到独立的文档中

Public Function SplitWorksheetByColumn( _    ByVal sourceSheet As Worksheet, _    ByVal splitColumn As Integer, _    ByVal headerRows As Integer, _    ByVal outputType As String, _    Optional ByVal outputPath As String = "" _) As Boolean    On Error GoTo ErrorHandler    ' 参数验证    If sourceSheet Is Nothing Then        MsgBox "源工作表不能为空", vbExclamation        Exit Function    End If    If splitColumn < 1 Or splitColumn > sourceSheet.UsedRange.Columns.Count Then        MsgBox "拆分列号超出有效范围", vbExclamation        Exit Function    End If    ' 设置    Application.ScreenUpdating = False    Application.Calculation = xlCalculationManual    Application.DisplayAlerts = False    ' 获取唯一值字典    Dim dict As Object    Set dict = GetUniqueValuesDictionary(sourceSheet, splitColumn, headerRows) '调用子过程    ' 根据输出类型执行不同拆分逻辑    Select Case LCase(outputType)        Case "工作表"            '预留接口，后续补充        Case "工作簿"            If outputPath = "" Then outputPath = ThisWorkbook.Path & "\拆分结果"            SplitToWorkbooks sourceSheet, dict, splitColumn, headerRows, outputPath & "\拆分结果"        Case Else            MsgBox "不支持的输出类型：" & outputType, vbExclamation            Exit Function    End Select    SplitWorksheetByColumn = True    GoTo CleanUpErrorHandler:    MsgBox "拆分过程中发生错误：" & Err.Description, vbCritical    SplitWorksheetByColumn = FalseCleanUp:    ' 恢复设置    Application.ScreenUpdating = True    Application.Calculation = xlCalculationAutomatic    Application.DisplayAlerts = True    ' 释放资源    Set dict = NothingEnd Function

Private Function GetUniqueValuesDictionary( _    ByVal sourceSheet As Worksheet, _    ByVal splitColumn As Integer, _    ByVal headerRows As Integer _) As Object    Dim dict As Object    Set dict = CreateObject("Scripting.Dictionary")    Dim lastRow As Long    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, splitColumn).End(xlUp).Row    Dim i As Long    For i = headerRows + 1 To lastRow        Dim keyValue As Variant        keyValue = sourceSheet.Cells(i, splitColumn).Value        ' 跳过空值        If Not IsEmpty(keyValue) And keyValue <> "" Then            ' 使用字典收集行范围            If Not dict.Exists(keyValue) Then                ' 新键值：创建行集合                Set dict(keyValue) = sourceSheet.Rows(i)            Else                ' 已有键值：合并行                Set dict(keyValue) = Union(dict(keyValue), sourceSheet.Rows(i))            End If        End If    Next i    Set GetUniqueValuesDictionary = dictEnd Function

Private Sub SplitToWorkbooks( _    ByVal sourceSheet As Worksheet, _    ByVal dict As Object, _    ByVal splitColumn As Integer, _    ByVal headerRows As Integer, _    ByVal outputPath As String _)    ' 创建输出文件夹    Dim fso As Object    Set fso = CreateObject("Scripting.FileSystemObject")    If Not fso.FolderExists(outputPath) Then        fso.CreateFolder outputPath    End If    Dim keys As Variant, items As Variant    keys = dict.keys    items = dict.items    Dim i As Long    For i = 0 To dict.Count - 1        ' 创建新工作簿        Dim newWorkbook As Workbook        Set newWorkbook = Workbooks.Add        Dim newSheet As Worksheet        Set newSheet = newWorkbook.Worksheets(1)        newSheet.Name = "数据"        ' 复制表头和数据        With newSheet            sourceSheet.Rows("1:" & headerRows).Copy            .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths '复制列宽            Application.CutCopyMode = False ' 清除剪贴板            ' 复制表头            sourceSheet.Rows("1:" & headerRows).Copy Destination:=.Range("A1")            ' 复制数据            items(i).Copy .Range("A" & headerRows + 1)        End With        Application.CutCopyMode = False        ' 保存文件        Dim fileName As String        fileName = CStr(keys(i)) & ".xlsx"        newWorkbook.SaveAs fileName:=outputPath & "\" & fileName, _                          FileFormat:=xlOpenXMLWorkbook        newWorkbook.Close SaveChanges:=False    Next i    Set fso = NothingEnd Sub