[已解决]多表取数

lgzxmlg

多表取数，请大家帮忙。谢谢老师。 生产统计日报表11月.zip (57.54 KB, 下载次数: 32)

2015-1-6 01:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-1-6 11:00

1. Sub Macro1()
   
2. Sheets("汇总").Activate
   
3. [a2:f20000].Clear
   
4. s = 1
   
5. For i = 1 To Sheets.Count
   
6.     If Sheets(i).Name <> "汇总" Then
   
7.         With Sheets(i)
   
8.             For j = 4 To 17
   
9.                 If Len(.Cells(j, 4)) > 0 Then
   
10.                     s = s + 1
    
11.                     Cells(s, 1) = Sheets(i).Name
    
12.                     Cells(s, 2) = .Cells(j, 2).MergeArea(1)
    
13.                     Cells(s, 3) = .Cells(j, 3)
    
14.                     Cells(s, 4) = .Cells(j, 10)
    
15.                     Cells(s, 5) = .Cells(j, 9)
    
16.                     Cells(s, 6) = .Cells(j, 14)
    
17.                 End If
    
18.             Next
    
19.         End With
    
20.      End If
    
21. Next
    
22. [a1].Resize(s, 6).Borders.LineStyle = 1
    
23. End Sub

复制代码

跳转到最佳答案楼层

tgydslr

无论怎样，在大型表格里出现合并单元格都会给数据处理汇总带来很大麻烦

芐雨

请测试

1. Sub 按钮1_Click()
   
2.     Dim arr, brr, i&, j&, crr, cName$$
   
3.     Dim sh As Worksheet, sht As Worksheet
   
4.     Set sh = Worksheets("汇总")
   
5.     ReDim brr(1 To 3000, 1 To 6)
   
6.     For Each sht In Worksheets
   
7.         If sht.Name <> sh.Name Then
   
8.             arr = sht.Range("A1").CurrentRegion
   
9.             For i = 4 To UBound(arr)
   
10.                 If arr(i, 1) = "合计" Then Exit For
    
11.                 If Len(arr(i, 2)) > 0 Then cName = arr(i, 2)
    
12.                 If arr(i, 1) <> "小计" And Len(arr(i, 3)) > 0 Then
    
13.                     x = x + 1
    
14.                     brr(x, 1) = sht.Name
    
15.                     brr(x, 2) = cName
    
16.                     brr(x, 3) = arr(i, 3)
    
17.                     brr(x, 4) = arr(i, 10)
    
18.                     brr(x, 5) = arr(i, 13)
    
19.                     brr(x, 6) = arr(i, 14)
    
20.                 End If
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     sh.Range("A1").CurrentRegion.Offset(1).Clear
    
25.     sh.Range("A2").Resize(x, 6) = brr
    
26.     sh.Range("A1").CurrentRegion.Borders.LineStyle = 1
    
27. End Sub

复制代码

芐雨

附件
生产统计日报表11月.zip (64.73 KB, 下载次数: 5)

2015-1-6 09:11 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. Sheets("汇总").Activate
   
3. [a2:f20000].Clear
   
4. s = 1
   
5. For i = 1 To Sheets.Count
   
6.     If Sheets(i).Name <> "汇总" Then
   
7.         With Sheets(i)
   
8.             For j = 4 To 17
   
9.                 If Len(.Cells(j, 4)) > 0 Then
   
10.                     s = s + 1
    
11.                     Cells(s, 1) = Sheets(i).Name
    
12.                     Cells(s, 2) = .Cells(j, 2).MergeArea(1)
    
13.                     Cells(s, 3) = .Cells(j, 3)
    
14.                     Cells(s, 4) = .Cells(j, 10)
    
15.                     Cells(s, 5) = .Cells(j, 9)
    
16.                     Cells(s, 6) = .Cells(j, 14)
    
17.                 End If
    
18.             Next
    
19.         End With
    
20.      End If
    
21. Next
    
22. [a1].Resize(s, 6).Borders.LineStyle = 1
    
23. End Sub

复制代码

dsmch

………………