本论坛相对最完善的汇总与分拆宏

棋行天下黄

Sub 汇总()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim str, str1, str2 As String, i As Integer, tr As Long
Cells.ClearContents
str1 = ThisWorkbook.Name
With ThisWorkbook.Sheets(1)
Set fso = CreateObject("scripting.filesystemobject")
Set FF = fso.getfolder(ThisWorkbook.Path)
For Each f In FF.Files
  If Not f.Name Like "*" & ThisWorkbook.Name & "*" Then
     Workbooks.Open f

     For i = 1 To Sheets.Count
     Sheets(i).Select
     tr = .[a1048576].End(xlUp).Row + 1
                    Set rng = Sheets(i).UsedRange
                    If rng.Rows.Count = 65536 Then
                        rng.Resize(65535).Offset(1).Copy .Range("a" & tr)
                        rng.Rows(65536).Copy .Range("a" & tr + 65535)
                        Else
                         ActiveSheet.UsedRange.Offset(1).Copy .Range("a" & tr)
                    End If
                Next i


    ActiveWorkbook.Close False
  End If
Next f

Set FF = fso.getfolder(ThisWorkbook.Path)
For Each sf In FF.subfolders
     For Each f In sf.Files

        Workbooks.Open f
         For i = 1 To Sheets.Count
     Sheets(i).Select
     tr = .[a1048576].End(xlUp).Row + 1
                    Set rng = Sheets(i).UsedRange
                    If rng.Rows.Count = 65536 Then
                        rng.Resize(65535).Offset(1).Copy .Range("a" & tr)
                        rng.Rows(65536).Copy .Range("a" & tr + 65535)
                        Else
                         ActiveSheet.UsedRange.Offset(1).Copy .Range("a" & tr)
                    End If
                Next i
      ActiveWorkbook.Close False
     Next

Next sf

End With

Set FF = fso.getfolder(ThisWorkbook.Path)
For Each f In FF.Files
  If Not f.Name Like "*" & ThisWorkbook.Name & "*" Then
     Workbooks.Open f



Exit For
End If
Next f
Set FF = Nothing
Set fso = Nothing
Rows("1:1").Select
    Selection.Copy
    Windows(str1).Activate
    Rows("1:1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Workbooks(f.Name).Activate
        str2 = f.Name
          Workbooks(f.Name).Saved = True
        ActiveWorkbook.Close SaveChanges:=False
         str = ThisWorkbook.Path

      If str2 Like "*.csv" Then
      ActiveWorkbook.SaveAs Filename:= _
        str & "\汇总表.csv", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Else
      ActiveWorkbook.SaveAs Filename:= _
        str & "\汇总表.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        End If

    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Delete
    Selection.Cut
    ActiveSheet.Shapes.Range(Array("Button 2")).Select
    Selection.Delete
    Selection.Cut
     ActiveSheet.Shapes.Range(Array("Button 3")).Select
    Selection.Delete
    Selection.Cut

    ActiveWorkbook.Save

End Sub


Sub 拆分表任意列()



' 快捷键: Ctrl+f
Dim wb As Workbook, arr, rng As Range, d As Object, k, t, sh As Worksheet, i&, J As string, str As String
    Set rng = Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   str = InputBox("请输入分拆后的文件名不需要关键字段名称")
    J = InputBox("请输入关键名称在第几列?请输入数字")
     arr = Range(J & "1:" & J & Range(J & Cells.Rows.Count).End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Cells(i, 1).Resize(1, Columns.Count)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, Columns.Count))
        End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[A1]
            t(i).Copy .[A2]
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & str & k(i) & ".xlsx"
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "汇总表已分拆完毕，拆分后的文件在文件夹中查找"
End Sub



本人在本论坛初学1月，代码大部分来源于论坛，并感谢赵老师等版主及网友指点，来源于论坛，供需要的朋友分享！附附件，放在要汇总的文件夹中即可运行，遍历每个工作簿，每个工作簿中的工作表，每个子文件夹，兼容2003版的EXCELL汇总（程序本身需2010版）
分拆要把分拆的文件打开按ctrl+f，错漏之处，敬请指教！

wenwen000424

作个记号，以便学习。

rachel.chen

tks
下载了

zhengchuan1971

作个记号，以便学习。

century_zhang

下载学习，多谢

鄂龙蒙

收藏学习了,谢谢!!!

awscn

标记下，这可能是我需要的东西啊

lcxam1

30页3000多行数据完美运行，谢谢前辈

walle666

学习了，谢谢

rio123

作个记号，以便学习。