同一工作薄多工作表合并数据到制定工作表

yfxfsj

同一工作薄多工作表合并数据到制定工作表，见附件说明

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim ws As Worksheet
   
5.   Dim ws0 As Worksheet
   
6.   Set ws0 = Worksheets("汇总")
   
7.   With ws0
   
8.     .UsedRange.Offset(1, 0).Clear
   
9.   End With
   
10.   For Each ws In Worksheets
    
11.     If ws.Name <> "汇总" Then
    
12.       With ws
    
13.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.         .Range("a4:e" & r).Copy ws0.Cells(ws0.Rows.Count, 1).End(xlUp).Offset(1, 0)
    
15.       End With
    
16.     End If
    
17.   Next
    
18. End Sub
    

复制代码

chxw68

详见附件。

yfxfsj

chxw68 发表于 2018-3-13 10:02
详见附件。

谢谢老师的热诚相助。

chxw68

yfxfsj 发表于 2018-3-13 10:09
谢谢老师的热诚相助。

应该是“指定”而不是“制定”吧？建议以后描述准确问题尽量准确一些，方便大家理解。

lsc900707

1. Sub gj23w98()
   
2.     Dim brr(1 To 100000, 1 To 5)
   
3.     For Each sht In Sheets
   
4.         If sht.Name <> ActiveSheet.Name Then
   
5.             With sht
   
6.                 r = .Cells(.Rows.Count, 1).End(3).Row
   
7.                 arr = .Range("a4:e" & r)
   
8.                 For i = 1 To UBound(arr)
   
9.                     If Len(arr(i, 1)) Then
   
10.                        m = m + 1
    
11.                        For j = 1 To 5
    
12.                            brr(m, j) = arr(i, j)
    
13.                        Next
    
14.                     End If
    
15.                 Next
    
16.             End With
    
17.         End If
    
18.     Next
    
19.     [a1].CurrentRegion.Offset(1).ClearContents
    
20.     [a2].Resize(m, 5) = brr
    
21. End Sub

复制代码

lsc900707

参考附件：

abc123281

呵呵  这种学习交流气氛太好了   可惜  我的鲜花已没了

abc123281

老师们  只有等待女楼主的鲜花了