ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 14866|回复: 25

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2013-10-19 23:40 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:多表合并和汇总
本帖最后由 棋行天下黄 于 2013-10-20 11:52 编辑

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,错漏之处,敬请指教!


复件 数据合并及分拆程序2013.10.21版.rar

45.1 KB, 下载次数: 2293

TA的精华主题

TA的得分主题

发表于 2013-10-20 07:53 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
作个记号,以便学习。

TA的精华主题

TA的得分主题

发表于 2014-12-11 12:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
tks
下载了

TA的精华主题

TA的得分主题

发表于 2015-2-24 15:20 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
作个记号,以便学习。

TA的精华主题

TA的得分主题

发表于 2015-3-2 22:23 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-4-13 17:01 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-4-30 00:26 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-9-14 11:31 | 显示全部楼层
30页3000多行数据完美运行,谢谢前辈

TA的精华主题

TA的得分主题

发表于 2015-12-1 18:12 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-12-22 17:07 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 19:19 , Processed in 0.061282 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表