Excel保留表头根据某列数值拆分数据并另存为若干新工作簿

发表评论
185

A+

数据样例：

index	内容	分类一	分类二
1	糖醋里脊	鲁菜	荤菜
2	锅贴	鲁菜	素菜
3	酱猪蹄	鲁菜	荤菜
4	鱼香肉丝	川菜	荤菜
5	宫保鸡丁	川菜	荤菜
6	麻婆豆腐	川菜	素菜
7	担担面	川菜	主食
8	小笼包子	苏菜	小吃
9	拉面	苏菜	主食

输入列号保存至当前目录

自动按照分类一或者分类二的分类方法，将数据表分割成多个文件。直接输入分割参考的列号，保存到同目录。

Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    c = Application.InputBox("请输入拆分列号，不要输字母，ABC对应123", , 4, , , , , 1)
    If c = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = [a1].Resize(, lc)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, c)) Then
            Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
        Else
            Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
        End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .Sheets(1).[a1]
            t(i).Copy .Sheets(1).[a2]
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "niubility!!!"
End Sub

自定义保存路径

可以在开发工具插入表单控件按钮，指定宏，运行即可。

Sub 保留表头拆分数据为若干新工作簿()
  Dim arr, d As Object, k, t, i&, lc%, rng As Range, c, reg, WorkPath, EndRow, RowVal, BookName, Mbox
  WorkPath = ActiveWorkbook.Path
  If WorkPath = "" Then
    i = MsgBox("未保存！" & vbCr & "是否设置保存路径？" & vbCr & vbCr & "点击 '是' 选择保存目录", vbYesNo)
    If i = vbYes Then
      WorkPath = 选择文件夹
    Else
      Exit Sub
    End If
  End If
  EndRow = 1 '表头行数
  For i = 1 To EndRow
    If Range("A" & i).Value = "" Then RowVal = RowVal & Range("A" & i).Address + ","
  Next
  If RowVal <> "" Then
    RowVal = Replace(Left(RowVal, Len(RowVal) - 1), "$", "")
    MsgBox "表头区域 A1:A" & EndRow & " 内的 " & RowVal & " 单元格不能为空值（可空格）"
    Exit Sub
  End If '区域错误判断
  c = Application.InputBox("请输入拆分列号", , 4)
  If c = False Then
    MsgBox ("请输入有效 英文列标 或 整数列号 ！")
    Exit Sub
  End If
  Set reg = CreateObject("vbscript.regexp") '正则
  With reg
    Mbox = "输入有误！" & vbCr & vbCr & "请输入有效 英文列标 或 整数列号 ！"
    .Pattern = "^[a-zA-Z]{1,}$"
    If .TEST(c) Then c = Columns(c).Column '字母判断
    .Pattern = "^$?[a-zA-Z]{1,3}$?d+$"
    If .TEST(c) Then c = Range(c).Column 'Range样式判断
    If IsNumeric(c) And c - Fix(c) = 0 Then
        c = c '整数判断
    ElseIf c = 0 Then
      MsgBox Mbox
      Exit Sub
    Else
      MsgBox Mbox
      Exit Sub
    End If
  End With
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  arr = Range("A" & EndRow).CurrentRegion
  lc = UBound(arr, 2)
  Set rng = Rows("1:" & EndRow).Resize(, lc)
  Set d = CreateObject("scripting.dictionary")
  For i = EndRow + 1 To UBound(arr)
    If Not d.Exists(arr(i, c)) Then
      Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
    Else
      Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
    End If
  Next
  k = d.Keys
  t = d.Items
  For i = 0 To d.Count - 1
    BookName = k(i)
    With Workbooks.Add(xlWBATWorksheet)
      rng.Copy .Sheets(1).[A1]
      t(i).Copy .Sheets(1).Range("A" & EndRow + 1)
      .SaveAs fileName:=WorkPath & "" & BookName & ".xls" '"D:Test" & BookName & ".xls" '
      .Close
    End With
  Next
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox "完毕"
End Sub
Function 选择文件夹()
  Dim File
  Set File = Application.FileDialog(msoFileDialogFolderPicker)
  With File
    .Title = "请选择需要保存的文件夹"
    .InitialFileName = "D:"
  End With
  File.Show
  选择文件夹 = File.SelectedItems(1)
End Function

这个版本更复杂些，其中，EndRow为表头结束行号，如果有多行表头的话，修改EndRow值。

前端输入拆分参考的列号，标题行

Sub 拆分成多个文件()

    '输入用户想要拆分的工作表
    Dim sheet_name
    sheet_name = Application.InputBox("请输入拆分工作表的名称：")
    Worksheets(sheet_name).Select

    '输入获取拆分需要的条件列
    Dim col_name
    col_name = Application.InputBox("请输入拆分依据的列号(如A):")

    '输入拆分的开始行，要求输入的是数字
    Dim start_row As Integer
    start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)

    '暂停屏幕更新
    Application.ScreenUpdating = False

    '工作表的总行数
    Dim end_row
    end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row

    '遍历计算所有拆分表，每个拆分表的格式为"表名称,表行数"
    '对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列
    Dim sheet_map(), sheet_index
    ReDim sheet_map(1, 0)
    sheet_map(0, 0) = Range(col_name & start_row).Value
    sheet_map(1, 0) = 1
    sheet_index = 0

    With Worksheets(sheet_name)
        Dim row_count, temp, i
        row_count = 0
        For i = start_row + 1 To end_row
            temp = Range(col_name & i).Value
            If temp = Range(col_name & (i - 1)).Value Then
                sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
            Else
                ReDim Preserve sheet_map(1, sheet_index + 1)
                sheet_index = sheet_index + 1
                sheet_map(0, sheet_index) = temp
                sheet_map(1, sheet_index) = 1
            End If
        Next
    End With

    '根据前面计算的拆分表，拆分成单个文件
    Dim row_index
    row_index = start_row
    For i = 0 To sheet_index
        Workbooks.Add
        '创建最终数据文件夹
        Dim dir_name
        dir_name = ThisWorkbook.Path & "\拆分出的表格\"
        If Dir(dir_name, vbDirectory) = "" Then
            MkDir (dir_name)
        End If
        '创建新工作簿
        Dim workbook_path
        workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xls"
        ActiveWorkbook.SaveAs Filename:=workbook_path, FileFormat:=-4143
        ActiveSheet.Name = sheet_map(0, i)
        '激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
        ThisWorkbook.Activate

        '拷贝条目数据(即最前面不需要拆分的数据行)
        Dim row_range
        row_range = 1 & ":" & (start_row - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A1").PasteSpecial
        '拷贝拆分表的专属数据
        row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A" & start_row).PasteSpecial
        row_index = row_index + sheet_map(1, i)

        '保存文件
        Workbooks(sheet_map(0, i) & ".xls").Close SaveChanges:=True
    Next

    '进行屏幕更新
    Application.ScreenUpdating = True

    MsgBox "拆分工作表完成"

End Sub

打赏赞