EXCEL VBA 对多个表格进行批量汇总实例

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

因为是VBA 新手，程序是自己编的，有一些明显不完善的地方，就拿出来和大家分享交流学习吧。

觉得还能看，大家就多多回复捧场就好

程序说明：

现有600xxx-600xxx的两个文件夹的文件。文件夹一中，文件名为“现任管理层[600xxx.SH].xls"，文件二中为”离任高管[600xxx.SH].xls"

现希望：

1 将现任管理层的表格中A列前添加一列并填写“现任管理层”字样，添加一列输入股票代码；离任高管的表格中类同

2 批量汇总上述两个文件夹中修改后的内容到一个表格内

缺点：

文件命名需要有规律，此处为数字的递增规律，同时，因为有断点所以数字不连续的地方需要分开进行两次程序操作。

有好的地方的话大家可以借鉴，可以改进的地方望各位不吝赐教，多谢！

Public Sub huizong()

t =1

Range("a1").Select

Fori = 600350 To 600590

d1 ="D:\常使用文件\Documents\Downloads\现任管理层[" & Str(i) & ".SH].xls"

arr1= Split(d1, " ")

  d =arr1(0) & arr1(1)

Workbooks.Open d

  a1= "D:\常使用文件\Documents\Downloads\离任高管[" & Str(i) & ".SH].xls"

arr2 = Split(a1, " ")

  a =arr2(0) & arr2(1)

  e1= "现任管理层[" & Str(i) & ".SH].xls"

arr3 = Split(e1, " ")

  e =arr3(0) & arr3(1)

  b1= "离任高管[" & Str(i) & ".SH].xls"

arr4 = Split(b1, " ")

  b =arr4(0) & arr4(1)

Workbooks(e).Activate   '选定现任表格

Range("A5").Select

Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove

Range("B5").Select

Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove  '插入两列

j =4

   DoWhile (Cells(j + 2, 5) Like "*" & "/" &"*") Or (Cells(j + 1, 5) Like "*" & "/" &"*") Or (Cells(j, 5) Like "*" & "/" &"*") Or (Cells(j + 3, 5) Like "*" & "/" &"*")

  Cells(j, 1) = Str(i)

  Cells(j, 2) = "现任"

   j= j + 1

  Loop

    s = j - 1   '以上为填充两列，s为需要粘贴的行数

    Cells(t, 1).Select

    Range(Cells(1, 1), Cells(s, 10)).Select

    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

    Selection.Copy

    Workbooks("汇总表.xlsm").Activate

    ActiveSheet.Paste

    t = t + s

    Cells(t, 1).Select

   c1 = "现任管理层[" & Str(i) & ".SH].xls"

   arr5 = Split(c1, " ")

    c= arr5(0) & arr5(1)

   Application.CutCopyMode = xlCut

   Workbooks(c).Close savechanges = True         '关闭已经打开的工作簿

   Cells(t,1).Select

  Workbooks.Open a         '选定离任表格

Workbooks(b).Activate

   Range("A5").Select

Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove

Range("B5").Select

Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove   '插入两列

k = 2

   DoWhile (Cells(k + 1, 5) Like "*" & "-" &"*") Or (Cells(k, 5) Like "*" & "-" &"*")

  Cells(k, 1) = Str(i)

  Cells(k, 2) = "离任"

   k= k + 1

  Loop

   u= k - 1           '以上为填充两列，u为需要粘贴的行数

  Range(Cells(1, 1), Cells(u, 11)).Select

   Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

   Selection.Copy

   Workbooks("汇总表.xlsm").Activate

   ActiveSheet.Paste

    t= t + u

   g1 = "离任高管[" & Str(i) & ".SH].xls"

   arr6 = Split(g1, " ")

    g= arr6(0) & arr6(1)

   Application.CutCopyMode = xlCut

   Workbooks(g).Close savechanges = True         '关闭已经打开的工作簿

   Cells(t + 1, 1).Select

Next

End Sub

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏2 回帖

关键词：EXCEL exce xcel cel VBA Documents 股票代码 文件夹 管理层 EXCEL

工具栏上有插入代码的选项，可以利用这一工具排版代码，这样比较美观。
另外，不管求助还是分享，都请上传附件或模拟一个附件，这样方便会的坛友给你提供帮助，否则会很麻烦。

客初 发表于 2015-10-15 12:09
工具栏上有插入代码的选项，可以利用这一工具排版代码，这样比较美观。
另外，不管求助还是分享，都请上传 ...

多谢指出！

好像没有吧