批量将工作表转换为独立的工作簿

  1. Sub EachShtToWorkbook()
  2.     Dim sht As Worksheet, strPath As String
  3.     With Application.FileDialog(msoFileDialogFolderPicker)
  4.    '选择保存工作薄的文件路径
  5.         If .Show Then strPath = .SelectedItems(1) Else Exit Sub
  6.         '读取选择的文件路径,如果用户未选取路径则退出程序
  7.     End With
  8.     If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  9.     Application.DisplayAlerts = False
  10.     '取消显示系统警告和消息，避免重名工作簿无法保存。当有重名工作簿时，会直接覆盖保存。
  11.     Application.ScreenUpdating = False '取消屏幕刷新
  12.     For Each sht In Worksheets '遍历工作表
  13.         sht.Copy '复制工作表，工作表单纯复制后，会成为活动工作薄
  14.         With ActiveWorkbook
  15.             .SaveAs strPath & sht.Name, xlWorkbookDefault
  16.             '保存活动工作薄到指定路径下，以当前系统默认文件格式
  17.             .Close True '关闭工作薄并保存
  18.         End With
  19.     Next
  20.     MsgBox "处理完成。", , "提醒"
  21.     Application.ScreenUpdating = True '恢复屏幕刷新
  22.     Application.DisplayAlerts = True '恢复显示系统警告和消息
  23. End Sub

1.按任意列拆分多个表

  1. Sub SplitShts()
  2.     Dim d As Object, sht As Worksheet
  3.     Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
  4.     Dim rngData As Range, rngGist As Range
  5.     Dim lngTitleCount&, lngGistCol&, lngColCount&
  6.     Dim rngFormat As Range, aRef, strYesOrNo As String
  7.     Dim strKey As String, strTemp As String
  8.     On Error Resume Next '忽略错误，程序继续运行
  9.     Set d = CreateObject("scripting.dictionary")
  10.     Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
  11.     '用户选择的拆分依据列
  12.     lngGistCol = rngGist.Column
  13.     '拆分依据列的列标
  14.     lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))
  15.     '用户设置总表的标题行数
  16.     If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
  17.     strYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)
  18.     Set rngData = rngGist.Parent.UsedRange
  19.     '总表的数据区域
  20.     Set rngFormat = rngGist.Parent.Cells
  21.     '总表的单元格区域用于粘贴总表格式
  22.     aData = rngData.Value '数据源装入数组
  23.     lngGistCol = lngGistCol - rngData.Column + 1
  24.     '计算依据列在数组中的位置
  25.     lngColCount = UBound(aData, 2)
  26.     '数据源的列数
  27.     Application.ScreenUpdating = False
  28.     Application.DisplayAlerts = False
  29.     ReDim aRef(1 To UBound(aData))
  30.     For i = 1 To UBound(aData) '处理依据列的异常值，空白/错误值/整行空白等
  31.         If IsError(aData(i, lngGistCol)) Then
  32.             aRef(i) = "错误值"
  33.         ElseIf aData(i, lngGistCol) = "" Then
  34.             strTemp = "" '判断是否整行数据为空
  35.             For j = 1 To lngColCount
  36.                 strTemp = strTemp & aData(i, j)
  37.             Next
  38.             If strTemp = "" Then '如果整行为空
  39.                 aRef(i) = "整行空白"
  40.             Else
  41.                 aRef(i) = "空白单元格"
  42.             End If
  43.         Else
  44.             strKey = aData(i, lngGistCol)
  45.             aRef(i) = strKey
  46.         End If
  47.     Next
  48.     For i = lngTitleCount + 1 To UBound(aData)
  49.         strKey = aRef(i)
  50.         If strKey <> "整行空白" Then
  51.             If Not d.exists(strKey) Then
  52.             '字典中不存在关键字时则遍历建表
  53.                 d(strKey) = ""
  54.                 ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组
  55.                 k = 0
  56.                 For x = lngTitleCount + 1 To UBound(aData) '遍历数据源
  57.                     strTemp = aRef(x)
  58.                     If strTemp = strKey Then '如果记录符合条件，则装入结果数组
  59.                         k = k + 1
  60.                         For j = 1 To lngColCount
  61.                             aResult(k, j) = aData(x, j)
  62.                         Next
  63.                     End If
  64.                 Next
  65.                 For Each sht In ActiveWorkbook.Worksheets '删除旧表
  66.                     If sht.Name = strKey Then sht.Delete
  67.                 Next
  68.                 With Worksheets.Add(, Sheets(Sheets.Count))
  69.                 '新建一个工作表
  70.                     .Name = strKey
  71.                     .Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"
  72.                     '设置单元格为文本格式
  73.                     If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData
  74.                     '标题行
  75.                     .Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
  76.                     '写入数据
  77.                     If strYesOrNo = vbYes Then '如果用户选择保留总表格式
  78.                         rngFormat.Copy
  79.                         .Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  80.                          '复制粘贴总表的格式
  81.                         .Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
  82.                         '删除多余的格式单元格
  83.                     End If
  84.                     .Range("a1").Select
  85.                 End With
  86.             End If
  87.         End If
  88.     Next
  89.     rngData.Parent.Activate '回到总表
  90.     Application.ScreenUpdating = True
  91.     Application.DisplayAlerts = True
  92.     Set d = Nothing
  93.     Set rngData = Nothing
  94.     Set rngGist = Nothing
  95.     Set rngFormat = Nothing
  96.     Erase aData: Erase aResult
  97.     MsgBox "数据拆分完成！"
  98. End Sub

1.追加汇总各分表数据成总表【不保留分表格式】

  1. Sub CollectData()
  2.     Dim Sht As Worksheet, rng As Range, k&, n&
  3.     Application.ScreenUpdating = False
  4.     '取消屏幕更新
  5.     n = Val(InputBox("请输入标题的行数", "提醒"))
  6.     If n < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
  7.     '取得用户输入的标题行数，如果为负数，退出程序
  8.     Cells.ClearContents
  9.     '清空当前表数据
  10.     For Each Sht In Worksheets
  11.     '遍历工作表
  12.         If Sht.Name <> ActiveSheet.Name Then
  13.         '如果工作表名称不等于当前表名则进行汇总动作……
  14.             Set rng = Sht.UsedRange
  15.             '定义rng为表格已用区域
  16.             k = k + 1
  17.             '累计K值
  18.             If k = 1 Then
  19.             '如果是首个表格，则K为1，则把标题行一起复制到汇总表
  20.                 rng.Copy
  21.                 [a1].PasteSpecial Paste:=xlPasteValues '仅粘贴数值
  22.             Else
  23.                 '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
  24.                 rng.Offset(n).Copy
  25.                 Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial Paste:=xlPasteValues
  26.             End If
  27.         End If
  28.     Next
  29.     [a1].Activate
  30.     Application.ScreenUpdating = True '恢复屏幕刷新
  31. End Sub

2.按任意列拆分方法二

2.追加汇总分表成总表（保留分表格式）

  1. Sub CollectDataFromShtFormat()
  2.     Dim sht As Worksheet, rng As Range, k As Long, nTitleCount As Long
  3.     On Error Resume Next
  4.     nTitleCount = Val(InputBox("请输入标题的行数", "提醒", 1))
  5.     If nTitleCount < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
  6.     Application.ScreenUpdating = False
  7.     Cells.ClearContents '清空当前表数据
  8.     For Each sht In Worksheets '遍历工作表
  9.         If sht.Name <> ActiveSheet.Name Then
  10.         '如果工作表名称不等于当前表名则进行汇总动作……
  11.             Set rng = sht.UsedRange
  12.             k = k + 1 '累计K值
  13.             If k = 1 Then '如果是首个表格，则K为1，则把标题行一起复制到汇总表
  14.                 sht.Cells.Copy: Range("a1").PasteSpecial Paste:=xlPasteFormats '只粘贴格式
  15.                 rng.Copy: Range("a1").PasteSpecial Paste:=xlPasteValues '只粘贴数值
  16.             Else '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
  17.                 rng.Offset(nTitleCount).Copy
  18.                 With Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
  19.                     .PasteSpecial Paste:=xlPasteFormats '粘贴格式
  20.                     .PasteSpecial Paste:=xlPasteValues '粘贴数值
  21.                 End With
  22.             End If
  23.         End If
  24.     Next
  25.     Range("a1").Activate
  26.     Application.ScreenUpdating = True '恢复屏幕刷新
  27.     MsgBox "汇总OK，一共汇总了：" & k & "张工作表"
  28. End Sub

按指定行数拆分表成多个工作簿并限定列

  1. Sub shishi2()
  2. Set 工作表 = ThisWorkbook.ActiveSheet
  3.     总行数 = 工作表.Range("A1").CurrentRegion.Rows.Count - 1
  4.     分割行数 = 3
  5. '算一下份数
  6. If 总行数 Mod 分割行数 Then
  7.     份数 = Int(总行数 / 分割行数) + 1
  8. Else
  9. 份数 = 总行数 / 分割行数
  10. End If
  11. '处理每一份
  12. j = 2
  13. For i = 1 To 份数
  14.     Set 新工作簿 = Workbooks.Add
  15.         工作表.Rows("1").Copy 新工作簿.Sheets(1).Range("A1")
  16.         '留下表头
  17.         工作表.Rows(j & ":" & j + 分割行数 - 1).Copy 新工作簿.Sheets(1).Range("A2")
  18.         新工作簿.Sheets(1).Columns("D:E").Delete '只要前三列
  19.         新工作簿.SaveAs "F:\" & i & ".xlsx"
  20.         新工作簿.Close
  21.         Set 新工作簿 = Nothing
  22.     j = j + 分割行数
  23. Next
  24. End Sub

合并多工作簿数据成总表

  1. Sub CollectWorkBookDatas()
  2.     Dim shtActive As Worksheet, rng As Range, shtData As Worksheet
  3.     Dim nTitleRow As Long, k As Long, nLastRow As Long
  4.     Dim i As Long, j As Long, nStartRow As Long
  5.     Dim aData, aResult, nStarRng As Long
  6.     Dim strPath As String, strFileName As String
  7.     Dim strKey As String, nShtCount As Long
  8.     With Application.FileDialog(msoFileDialogFolderPicker)
  9.     '取得用户选择的文件夹路径
  10.         If .Show Then strPath = .SelectedItems(1) Else Exit Sub
  11.     End With
  12.     If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  13.     strKey = InputBox("请输入需要合并的工作表所包含的关键词：" & vbCrLf & "如未填写关键词，则默认汇总全部表格数据", "提醒")
  14.     If StrPtr(strKey) = 0 Then Exit Sub '如果点击了取消或者关闭按钮，则退出程序
  15.     nTitleRow = Val(InputBox("请输入标题的行数，默认标题行数为1", "提醒", 1))
  16.     If nTitleRow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
  17.     Set shtActive = ActiveSheet
  18.     With Application
  19.         .ScreenUpdating = False
  20.         .DisplayAlerts = False
  21.         .AskToUpdateLinks = False
  22.     End With
  23.     ReDim aResult(1 To 80000, 1 To 1) '声明结果数组
  24.     Cells.ClearContents '清空当前表格数据
  25.     Cells.NumberFormat = "@" '设置单元格为文本格式
  26.     strFileName = Dir(strPath & "*.xls*") '使用Dir函数遍历excel文件
  27.     Do While strFileName <> ""
  28.         If strFileName <> ThisWorkbook.Name Then '避免同名文件重复打开出错
  29.             With GetObject(strPath & strFileName)
  30.             '以只读'形式读取文件时，使用getobject会比workbooks.open稍快
  31.                 For Each shtData In .Worksheets '遍历表
  32.                     If InStr(1, shtData.Name, strKey, vbTextCompare) Then
  33.                     '如果表中包含关键字则进行汇总(不区分关键词字母大小写）
  34.                         Set rng = shtData.UsedRange
  35.                         If rng.Count > 1 Then '判断工作表是否存在数据……
  36.                             nShtCount = nShtCount + 1 '汇总工作表的数量
  37.                             nStartRow = IIf(nShtCount = 1, 1, nTitleRow + 1) '判断遍历数据源是否应该扣掉标题行
  38.                             aData = rng.Value '数据区域读入数组arr
  39.                             If UBound(aData, 2) + 2 > UBound(aResult, 2) Then '动态调整结果数组brr的最大列数
  40.                                 ReDim Preserve aResult(1 To UBound(aResult), 1 To UBound(aData, 2) + 2)
  41.                             End If
  42.                             For i = nStartRow To UBound(aData) '遍历行
  43.                                 k = k + 1
  44.                                 aResult(k, 1) = strFileName '数组第一列放工作簿名称
  45.                                 aResult(k, 2) = shtData.Name '数组第二列放工作表名称
  46.                                 For j = 1 To UBound(aData, 2) '遍历列
  47.                                     aResult(k, j + 2) = aData(i, j)
  48.                                 Next
  49.                                 If k > UBound(aResult) - 1 Then
  50.                                 '如果数据行数到达结果数组的上限，则将数据导入汇总表，并清空结果数组
  51.                                     With shtActive
  52.                                         nLastRow = .Cells(Rows.Count, 1).End(xlUp).Row '获取放置来源数据的位置
  53.                                         If nLastRow = 1 Then '判断是否扣除标题行
  54.                                             nStarRng = IIf(nTitleRow = 0, 1, 0)
  55.                                             .Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResult
  56.                                             .Range("a1:b1") = Array("来源工作簿名称", "来源工作表名称")
  57.                                             '前两列放来源工作簿和工作表名称
  58.                                         Else
  59.                                             .Range("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResult
  60.                                             '放结果数组的数据
  61.                                         End If
  62.                                     End With
  63.                                     k = 0
  64.                                     ReDim aResult(1 To UBound(aResult), 1 To UBound(aResult, 2))
  65.                                     '重新设置结果数组
  66.                                 End If
  67.                             Next
  68.                         End If
  69.                     End If
  70.                 Next
  71.                 .Close False '关闭工作簿
  72.             End With
  73.         End If
  74.         strFileName = Dir '下一个excel文件
  75.     Loop
  76.     If k > 0 Then
  77.         shtActive.Select '激活汇总表
  78.         nLastRow = Cells(Rows.Count, 1).End(xlUp).Row '放置数据的位置
  79.         If nLastRow = 1 Then '如果汇总表数据为空，说明需要汇总的数据没有超过结果数组的上限
  80.              nStarRng = IIf(nTitleRow = 0, 1, 0)
  81.              Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResult
  82.              Range("a1:b1") = Array("来源工作簿名称", "来源工作表名称")
  83.          Else
  84.              Range("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResult
  85.          End If
  86.     End If
  87.     With Application
  88.         .ScreenUpdating = True
  89.         .DisplayAlerts = True
  90.         .AskToUpdateLinks = True
  91.     End With
  92.     MsgBox "一共汇总完成。" & nShtCount & "个工作表", , "孙兴华"
  93. End Sub

将总表按任意列拆分成多个工作簿

Sub SplitShts()
    Dim d As Object, sht As Worksheet
    Dim aData, aResult, aTemp, aKeys, i&, j&, k&, x&
    Dim rngData As Range, rngGist As Range, ws As Workbook
    Dim lngTitleCount&, lngGistCol&, lngColCount&
    Dim rngFormat As Range, aRef, strYesOrNo As String
    Dim strKey As String, strTemp As String, strPath As String
    On Error Resume Next '忽略错误，程序继续运行
    Set d = CreateObject("scripting.dictionary")
    With Application.FileDialog(msoFileDialogFolderPicker)
    '用户选择保存工作簿的路径
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Set rngGist = Application.InputBox("请框选拆分依据列！只能选择单列单元格区域！", Title:="提示", Type:=8)
    '用户选择的拆分依据列
    If rngGist Is Nothing Then Exit Sub
    lngGistCol = rngGist.Column '拆分依据列的列标
    lngTitleCount = Val(Application.InputBox("请输入总表标题行的行数？", Default:=1))
    '用户设置总表的标题行数
    If lngTitleCount < 0 Then MsgBox "标题行数不能为负数，程序退出。": Exit Sub
    strYesOrNo = MsgBox("是否需要在分表保留总表格式？", vbYesNo)
    Set rngData = rngGist.Parent.UsedRange
    '总表的数据区域
    Set rngFormat = rngGist.Parent.Cells
    '总表的单元格区域用于粘贴总表格式
    aData = rngData.Value '数据源装入数组
    lngGistCol = lngGistCol - rngData.Column + 1
    '计算依据列在数组中的位置
    lngColCount = UBound(aData, 2)
    '数据源的列数
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ReDim aRef(1 To UBound(aData))
    For i = 1 To UBound(aData) '处理依据列的异常值，空白/错误值/整行空白等
        If IsError(aData(i, lngGistCol)) Then
            aRef(i) = "错误值"
        ElseIf aData(i, lngGistCol) = "" Then
            strTemp = "" '判断是否整行数据为空
            For j = 1 To lngColCount
                strTemp = strTemp & aData(i, j)
            Next
            If strTemp = "" Then '如果整行为空
                aRef(i) = "整行空白"
            Else
                aRef(i) = "空白单元格"
            End If
        Else
            strKey = aData(i, lngGistCol)
            aRef(i) = strKey
        End If
    Next
    For i = lngTitleCount + 1 To UBound(aData)
        strKey = aRef(i)
        If strKey <> "整行空白" Then
            If Not d.exists(strKey) Then
            '字典中不存在关键字时则遍历建表
                d(strKey) = ""
                ReDim aResult(1 To UBound(aData), 1 To lngColCount) '声明一个结果数组
                k = 0
                For x = lngTitleCount + 1 To UBound(aData) '遍历数据源
                    strTemp = aRef(x)
                    If strTemp = strKey Then '如果记录符合条件，则装入结果数组
                        k = k + 1
                        For j = 1 To lngColCount
                            aResult(k, j) = aData(x, j)
                        Next
                    End If
                Next
                Set ws = Workbooks.Add
                With ws.Sheets(1)
                '新建一个工作簿
                    .Range("a1").Resize(UBound(aData), lngColCount).NumberFormat = "@"
                    '设置单元格为文本格式
                    If lngTitleCount > 0 Then .Range("a1").Resize(lngTitleCount, lngColCount) = aData
                    '标题行
                    .Range("a1").Offset(lngTitleCount, 0).Resize(k, lngColCount) = aResult
                    '写入数据
                    If strYesOrNo = vbYes Then '如果用户选择保留总表格式
                        rngFormat.Copy
                        .Range("a1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                         '复制粘贴总表的格式
                        .Range("a1").Offset(lngTitleCount + k, 0).Resize(UBound(aData) - k - lngTitleCount, 1).EntireRow.Delete
                        '删除多余的格式单元格
                    End If
                    .Range("a1").Select
                End With
                ws.SaveAs strPath & strKey, xlWorkbookDefault
                ws.Close False
            End If
        End If
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set d = Nothing
    Set rngData = Nothing
    Set rngGist = Nothing
    Set rngFormat = Nothing
    Erase aData: Erase aResult
    MsgBox "数据拆分完成！"
End Sub