Excel批量、自动拆分工作簿与工作表

Sub 按追回年月拆分工作表()    Dim wsSource As Worksheet    Dim wsNew As Worksheet    Dim rngData As Range    Dim cell As Range    Dim dict As Object    Dim key As Variant    Dim lastRow As Long    Dim colIndex As Integer    Dim targetColName As String    Dim i As Integer' --- 配置区域 ---    targetColName = "追回年月" ' 请确保表头文字与此完全一致' --------------    ' 1. 设置源工作表（当前激活的工作表）    Set wsSource = ActiveSheet' 2. 关闭屏幕刷新和警告，提高运行速度    Application.ScreenUpdating = False    Application.DisplayAlerts = False    ' 3. 查找“追回年月”列的位置    colIndex = 0    For i = 1 To wsSource.Cells(1, Columns.Count).End(xlToLeft).Column        If wsSource.Cells(1, i).Value = targetColName Then            colIndex = i            Exit For        End If    Next i' 如果没找到列，提示并退出    If colIndex = 0 Then        MsgBox "未找到标题为【" & targetColName & "】的列，请检查表头！", vbExclamation        GoTo CleanExit    End If    ' 4. 获取所有唯一的“追回年月”值    Set dict = CreateObject("Scripting.Dictionary")    lastRow = wsSource.Cells(wsSource.Rows.Count, colIndex).End(xlUp).Row' 遍历该列，将唯一的月份存入字典    For Each cell In wsSource.Range(wsSource.Cells(2, colIndex), wsSource.Cells(lastRow, colIndex))        If cell.Value <> "" Then            If Not dict.Exists(cell.Value) Then                dict.Add cell.Value, Nothing            End If        End If    Next cell    ' 5. 循环每个唯一的月份，进行筛选和复制    For Each key In dict.Keys' 如果工作表已存在，先删除（防止报错，保持数据最新）        On Error Resume Next        Set wsNew = Sheets(CStr(key))        If Not wsNew Is Nothing Then            wsNew.Delete        End If        On Error GoTo 0        ' 使用自动筛选        wsSource.Range("A1").AutoFilter Field:=colIndex, Criteria1:=key' 复制可见单元格（筛选后的结果）        On Error Resume Next ' 防止如果没有数据行报错        Set rngData = wsSource.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)        On Error GoTo 0        If Not rngData Is Nothing Then' 新建工作表            Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))            wsNew.Name = CStr(key)            ' 粘贴数据            rngData.Copy wsNew.Range("A1")' 简单的格式调整：自动调整列宽            wsNew.Columns.AutoFit        End If        ' 重置变量        Set rngData = Nothing        Set wsNew = Nothing    Next key' 6. 取消筛选，恢复原状    wsSource.AutoFilterMode = False    MsgBox "拆分完成！共生成 " & dict.Count & " 个工作表。", vbInformationCleanExit:    Application.ScreenUpdating = True    Application.DisplayAlerts = TrueEnd Sub

📝 如何使用

打开 WPS 表格，按下快捷键 Alt + F11 打开 VBA 编辑器。在左侧的项目窗口中，右键点击你的工作簿名称，选择 插入 -> 模块。将上面的代码完整复制并粘贴到右侧的空白代码窗口中。关闭 VBA 编辑器，回到表格界面。按下 Alt + F8，选择 按追回年月拆分工作表，然后点击“运行”。