[已解决]同目录下多表汇总的扩展问题

婉君妹妹

各位大侠：下午好！                  
                  
一.     3个大表里面各有3个sheet，目前的宏只能汇总每个大表的第1个sheet的全部内容。期望能取出所有大表下所有有内容的sheet的E列和H列，转置后按顺序排列；
以十二生肖表举例：
虎5        虎5        虎5        虎5        虎5        虎5        虎5        虎5        虎5        虎5
虎8        虎8        虎8        虎8        虎8        虎8        虎8        虎8        虎8        虎8
龙5        龙5        龙5        龙5        龙5        龙5        龙5        龙5        龙5        龙5
龙8        龙8        龙8        龙8        龙8        龙8        龙8        龙8        龙8        龙8
兔5        兔5        兔5        兔5        兔5        兔5        兔5        兔5        兔5        兔5
兔8        兔8        兔8        兔8        兔8        兔8        兔8        兔8        兔8        兔8


二.     目前汇总结果没有按照文件夹里excel文件的排序来，文件夹里是： 杭州，十二生肖，数字汉字。但目前宏执行后是：十二生肖，数字汉字，杭州。
        期望最终的结果能按照文件夹里excel顺序来排序。


恳请大侠出手相助，小的给你发红包{:021:}

最佳答案

月排行榜 / 总排行榜

七彩屋

2016-8-28 21:15

婉君妹妹 发表于 2016-8-28 18:04
发现漏了一点没说清楚，还需要把每个sheet的名字放在转置后每行数据的前面。
但是我模仿你帮我解答的上 ...

1. Sub HuiZong()
   
2. Dim myfile, mypath, wb, X, Y, i, J          '声明变量
   
3. Application.ScreenUpdating = False   '关闭屏幕更新
   
4. Sheet1.UsedRange.Offset(1, 0).Clear  '清除除表头之外的所有内容
   
5. mypath = ThisWorkbook.Path           '找到当前工作簿的路径
   
6. myfile = Dir(mypath & "\*.xls*")     '遍历当前文件夹下的Excel文件
   
7. Do While myfile <> ""                '当找到的文件不为空时
   
8.    If myfile <> ThisWorkbook.Name Then   '当找到的文件不是当前Excel工作簿时
   
9.       Set wb = GetObject(mypath & "" & myfile)   '得到dir找到的工作簿的内容，设为wb
   
10.      For J = 1 To wb.Sheets.Count
    
11.       With wb.Sheets(J)              '对找到的工作簿的sheet1进行操作
    
12.          X = .[E65536].End(xlUp).Row
    
13.          Y = .[H65536].End(xlUp).Row
    
14.              ARR = Application.Transpose(.Range("E1:E" & X))
    
15.              BRR = Application.Transpose(.Range("H1:H" & Y))
    
16.                  i = Range("a65536").End(xlUp).Row + 1
    
17.                    Cells(i, 1) = .Name & "资金"
    
18.                    Cells(i, 2).Resize(1, X) = ARR
    
19.                      Cells(i + 1, 1) = .Name & "人数"
    
20.                      Cells(i + 1, 2).Resize(1, Y) = BRR
    
21.       End With
    
22.      Next
    
23.       wb.Close False      '关闭wb工作簿且不保存
    
24.    End If
    
25.    myfile = Dir          '寻找下一个Excel工作簿
    
26. Loop
    
27. Application.ScreenUpdating = True   '恢复屏幕更新
    
28. End Sub

复制代码

跳转到最佳答案楼层

七彩屋

同路径下多表汇总成一页.rar (45.61 KB, 下载次数: 17)

2016-8-28 17:18 上传

点击文件名下载附件

七彩屋

1. <div class="blockcode"><blockquote>Sub HuiZong()
   
2. Dim myfile, mypath, wb, X, Y, i, J          '声明变量
   
3. Application.ScreenUpdating = False   '关闭屏幕更新
   
4. Sheet1.UsedRange.Offset(1, 0).Clear  '清除除表头之外的所有内容
   
5. mypath = ThisWorkbook.Path           '找到当前工作簿的路径
   
6. myfile = Dir(mypath & "\*.xls*")     '遍历当前文件夹下的Excel文件
   
7. Do While myfile <> ""                '当找到的文件不为空时
   
8.    If myfile <> ThisWorkbook.Name Then   '当找到的文件不是当前Excel工作簿时
   
9.       Set wb = GetObject(mypath & "" & myfile)   '得到dir找到的工作簿的内容，设为wb
   
10.      For J = 1 To wb.Sheets.Count
    
11.       With wb.Sheets(J)              '对找到的工作簿的sheet1进行操作
    
12.          X = .[E65536].End(xlUp).Row
    
13.          Y = .[H65536].End(xlUp).Row
    
14.              ARR = Application.Transpose(.Range("E1:E" & X))
    
15.              BRR = Application.Transpose(.Range("H1:H" & Y))
    
16.                  i = Range("a65536").End(xlUp).Row + 1
    
17.                    Cells(i, 1).Resize(1, X) = ARR
    
18.                    Cells(i + 1, 1).Resize(1, Y) = BRR
    
19.       End With
    
20.      Next
    
21.       wb.Close False      '关闭wb工作簿且不保存
    
22.    End If
    
23.    myfile = Dir          '寻找下一个Excel工作簿
    
24. Loop
    
25. Application.ScreenUpdating = True   '恢复屏幕更新
    
26. End Sub
    

复制代码

婉君妹妹

七彩屋 发表于 2016-8-28 17:43

大神，你太厉害了！太感谢你了！
我在你源代码的后面想加上表头和汉字，结果执行的时候弹出框提示说“要求对象”，数据也只能显示一行了
                ARR = Application.Transpose(.Range("E5:E80"))
                 BRR = Application.Transpose(.Range("H5:H80"))
                 Cells(I, 2).Resize(1, 76) = ARR
                 Cells(I, 1) = Sht.Name & "资金"
                   I = I + 1
                 Cells(I, 2).Resize(1, 76) = BRR
                 Cells(I, 1) = Sht.Name & "人数"
                   I = I + 1


求解

婉君妹妹

七彩屋 发表于 2016-8-28 17:43

发现漏了一点没说清楚，还需要把每个sheet的名字放在转置后每行数据的前面。
但是我模仿你帮我解答的上一个问题，把代码挪过去之后，
Cells(I, 1) = Sht.Name & "1"
发现无法执行。 删掉后又好了。

七彩屋

婉君妹妹 发表于 2016-8-28 18:04
发现漏了一点没说清楚，还需要把每个sheet的名字放在转置后每行数据的前面。
但是我模仿你帮我解答的上 ...

1. Sub HuiZong()
   
2. Dim myfile, mypath, wb, X, Y, i, J          '声明变量
   
3. Application.ScreenUpdating = False   '关闭屏幕更新
   
4. Sheet1.UsedRange.Offset(1, 0).Clear  '清除除表头之外的所有内容
   
5. mypath = ThisWorkbook.Path           '找到当前工作簿的路径
   
6. myfile = Dir(mypath & "\*.xls*")     '遍历当前文件夹下的Excel文件
   
7. Do While myfile <> ""                '当找到的文件不为空时
   
8.    If myfile <> ThisWorkbook.Name Then   '当找到的文件不是当前Excel工作簿时
   
9.       Set wb = GetObject(mypath & "" & myfile)   '得到dir找到的工作簿的内容，设为wb
   
10.      For J = 1 To wb.Sheets.Count
    
11.       With wb.Sheets(J)              '对找到的工作簿的sheet1进行操作
    
12.          X = .[E65536].End(xlUp).Row
    
13.          Y = .[H65536].End(xlUp).Row
    
14.              ARR = Application.Transpose(.Range("E1:E" & X))
    
15.              BRR = Application.Transpose(.Range("H1:H" & Y))
    
16.                  i = Range("a65536").End(xlUp).Row + 1
    
17.                    Cells(i, 1) = .Name & "资金"
    
18.                    Cells(i, 2).Resize(1, X) = ARR
    
19.                      Cells(i + 1, 1) = .Name & "人数"
    
20.                      Cells(i + 1, 2).Resize(1, Y) = BRR
    
21.       End With
    
22.      Next
    
23.       wb.Close False      '关闭wb工作簿且不保存
    
24.    End If
    
25.    myfile = Dir          '寻找下一个Excel工作簿
    
26. Loop
    
27. Application.ScreenUpdating = True   '恢复屏幕更新
    
28. End Sub

复制代码

婉君妹妹

感谢大神！