[已解决]求助，如何遍历名字为汉字的多个工作表

yangjfas

那位高手能帮忙，先谢谢了。
一个EXCEL 中有多个 不同名字的工作表，要求使用一个程序首先对每个表进行连续计算，将D列大于20的数据行a、b、c、d及其下二行复制到e、f、g、h，并在序列号上自动加上1，2，3。然后将每个表中的e、f、g、h、i列数据复制到汇总表中并在汇总表中每列数据前注明是那个单位的。这是个例子，实际上表中有许多单位，反复复制实在太慢了。我自己编程处理了一下，单个表的数据处理并不难，但由于每个工作表的名字是汉字，无规律可言，因此一个处理程序无法遍历所有的工作表。不知这个问题如何解决
     曾经用网上搜寻到某老师的一个程序，但使用后提示03行，“运行时错误438，对象不支持属性或方法”

• Sub Arrangement()
•     Dim wkSht As Worksheet
•     For Each wkSht In ThisWorkbook
•         With wkSht
•             '需要处理的代码，
•             
•         End With
•     Next
• End Sub
  

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-22 15:31

1. Sub Macro1()
   
2. Dim arr, brr, i%, j&, k%, s&, s2&
   
3. ReDim brr(1 To 60000, 1 To 6) '重新定义数组
   
4. For i = 1 To 4 '循环工作表
   
5.     dw = Sheets(i).Name '工作表名称
   
6.     With Sheets(i)
   
7.         arr = .Range("a1").CurrentRegion '赋值数组
   
8.         s2 = 0: .[e2:i60000] = "" '计数和区域清空
   
9.         For j = 2 To UBound(arr) '循环数组
   
10.             If arr(j, 4) > 20 Then '如第四列大于20则
    
11.                 s = s + 1: s2 = s2 + 1 '序号加1，汇总数据加1
    
12.                 .Cells(s2 + 1, 5) = s2 '第5列序号
    
13.                 .Cells(j, 1).Resize(1, 4).Copy .Cells(s2 + 1, "f") '复制
    
14.                 brr(s, 1) = dw: brr(s, 2) = s2 '汇总数据1-2列
    
15.                 For k = 1 To 4 '3-6列
    
16.                     brr(s, k + 2) = arr(j, k)
    
17.                 Next
    
18.             End If
    
19.         Next
    
20.     End With
    
21. Next
    
22. Sheets("汇总").Activate
    
23. [a2:f20000] = "" '预清空
    
24. If s > 0 Then Range("a2").Resize(s, 6) = brr '赋值单元格
    
25. End Sub

复制代码

跳转到最佳答案楼层

dsmch

………………

yangjfas

dsmch 发表于 2015-3-22 08:22
………………

非常好用，太感谢了，但老师能给我注解一下吗？我刚学VBA，看不太懂，并且增加一些工作表和数据后就不知道怎么能了。我想在了解后自己做一些修改

yangjfas

我怎么也没看懂那些指令实现了遍历多工作表

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i%, j&, k%, s&, s2&
   
3. ReDim brr(1 To 60000, 1 To 6) '重新定义数组
   
4. For i = 1 To 4 '循环工作表
   
5.     dw = Sheets(i).Name '工作表名称
   
6.     With Sheets(i)
   
7.         arr = .Range("a1").CurrentRegion '赋值数组
   
8.         s2 = 0: .[e2:i60000] = "" '计数和区域清空
   
9.         For j = 2 To UBound(arr) '循环数组
   
10.             If arr(j, 4) > 20 Then '如第四列大于20则
    
11.                 s = s + 1: s2 = s2 + 1 '序号加1，汇总数据加1
    
12.                 .Cells(s2 + 1, 5) = s2 '第5列序号
    
13.                 .Cells(j, 1).Resize(1, 4).Copy .Cells(s2 + 1, "f") '复制
    
14.                 brr(s, 1) = dw: brr(s, 2) = s2 '汇总数据1-2列
    
15.                 For k = 1 To 4 '3-6列
    
16.                     brr(s, k + 2) = arr(j, k)
    
17.                 Next
    
18.             End If
    
19.         Next
    
20.     End With
    
21. Next
    
22. Sheets("汇总").Activate
    
23. [a2:f20000] = "" '预清空
    
24. If s > 0 Then Range("a2").Resize(s, 6) = brr '赋值单元格
    
25. End Sub

复制代码