各自填各自的行，多工作薄汇总

99qiang

汇总表和下发单位的表格式是一模一样的，发给单位的表，每个单位只填自己的行，然后汇总，我自己写了一个，总觉得不是很好，求更好的代码。单位有100多家，其实下发表做成每个单位一行即可，只是经常遇到这样的求助，希望大家出手相助。

1. Sub ch()
   
2. Dim Mypath$, Myname$, x, wb As Workbook, sh As Worksheet, rg As Range
   
3. Application.ScreenUpdating = False
   
4. Range("b2:e11") = ""
   
5. Mypath = ThisWorkbook.Path & ""
   
6. Myname = Dir(Mypath & "*.xls")
   
7. Do While Myname <> ""
   
8.     If Myname <> ThisWorkbook.Name Then
   
9.     Set wb = Workbooks.Open(Mypath & Myname)
   
10.     Set sh = wb.Sheets(1)
    
11.     For Each rg In sh.Range("b2:e11")
    
12.          If rg.Value <> "" Then
    
13.               x = rg.Row
    
14.               arr = sh.Range("b" & x & ":e" & x)
    
15.               Workbooks("汇总.xls").Sheets(1).Range("b" & x & ":e" & x) = arr
    
16.               Exit For
    
17.           End If
    
18.     Next
    
19.     wb.Close False
    
20.     End If
    
21.     Myname = Dir
    
22. Loop
    
23. Application.ScreenUpdating = True
    
24. MsgBox "完成"
    
25. End Sub

复制代码

opiona

http://club.excelhome.net/thread-1409141-1-1.html

99qiang

你可能理解错了，我需要汇总的数据在每个工作薄中的位置不是固定的，坛子里我也搜过，但没找到。学过你的贴子，特别是你的自定义函数挺好的，向你学习

99qiang

opiona 发表于 2018-6-9 22:41
http://club.excelhome.net/thread-1409141-1-1.html

你可能没细看，我汇总的数据在各工作薄中的位置不固定。学过你的贴子，自定义函数很厉害，向你学习

lsc900707

数据多的话尽量避免操作单元格。

99qiang

lsc900707 发表于 2018-6-10 00:57
数据多的话尽量避免操作单元格。

怎么避免，能举个例子吗

lsc900707

99qiang 发表于 2018-6-10 08:08
怎么避免，能举个例子吗

1. Sub gj23w98()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = Dir(p & "*.xls")
   
6.     Do While Len(f)
   
7.         If f <> ThisWorkbook.Name Then
   
8.             With GetObject(p & f)
   
9.                 arr = .Sheets(1).[a1].CurrentRegion
   
10.                 .Close
    
11.             End With
    
12.             For i = 2 To UBound(arr)
    
13.                 For j = 2 To UBound(arr, 2)
    
14.                     If Len(arr(i, j)) Then
    
15.                         d(arr(i, 1) & arr(1, j)) = arr(i, j)
    
16.                     End If
    
17.                 Next
    
18.             Next
    
19.         End If
    
20.         f = Dir
    
21.     Loop
    
22.     brr = [a1].CurrentRegion
    
23.     For i = 2 To UBound(brr)
    
24.         For j = 2 To UBound(brr, 2)
    
25.             brr(i, j) = d(brr(i, 1) & brr(1, j))
    
26.         Next
    
27.     Next
    
28.     [a1].CurrentRegion = brr
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

lsc900707

附件供测试：

99qiang

lsc900707 发表于 2018-6-10 08:47

明白了，谢谢

jiminyanyan

http://club.excelhome.net/thread-1247778-1-1.html
我开发的工具。。。