根据表格，将对应标题的数据根据标题汇总到同一表中，提取数据的标题有横竖排列，谢谢

于箱长

sulli112 发表于 2021-10-11 16:55
我没有看到有附件上传

嗯，需要审核

不干的泪痕

写了个1000行的，试试

sulli112

于箱长 发表于 2021-10-11 17:46
嗯，需要审核

加了个忽略隐藏表格，之后非常完美，谢谢啦

1. Sub 开整()
   
2. Dim Arr, Sht As Worksheet, Brr(1 To 10000, 1 To 11)
   
3. For Each Sht In Worksheets
   
4.     If Sht.Name <> "加工明细表" And Sht.Visible = -1 Then
   
5.         With Sht
   
6.             Arr = .Range("a8:g" & .[d1048576].End(3).Row)
   
7.             For i = 1 To UBound(Arr) - 6
   
8.                 If Arr(i, 2) <> "" Then
   
9.                     n = n + 1
   
10.                     Brr(n, 1) = Right(.Cells(5, 1), Len(.Cells(5, 1)) - 6)
    
11.                     Brr(n, 2) = .Cells(6, 6)
    
12.                     Brr(n, 3) = .Cells(5, 6)
    
13.                     Brr(n, 4) = Arr(i, 1)
    
14.                     Brr(n, 5) = Arr(i, 2)
    
15.                     Brr(n, 6) = Arr(i, 3)
    
16.                     Brr(n, 7) = Arr(i, 4)
    
17.                     Brr(n, 8) = Arr(i, 5)
    
18.                     Brr(n, 11) = Arr(i, 7)
    
19.                 End If
    
20.             Next
    
21.         End With
    
22.     End If
    
23. Next
    
24. Sheets("加工明细表").[a4].Resize(UBound(Brr), 8) = Brr
    
25. Sheets("加工明细表").[k4].Resize(UBound(Brr), 1) = Application.Index(Brr, , 11)
    
26. MsgBox "完成"
    
27. End Sub
    
28. 
    

复制代码

sulli112

半百 发表于 2021-10-11 16:12
Sub 汇总()
Dim ARR(1 To 999, 1 To 8)
Set Sh = Sheets("加工明细表")

您好，大神，我想请教一下如果想加一下当表格隐藏的时候忽略汇总数据

1. sh.Visible = -1

复制代码

，请问要加在哪里呢，我试了几个位置好像都不太行

sulli112

不干的泪痕 发表于 2021-10-11 18:09
写了个1000行的，试试

可以用的，非常感谢

半百

sulli112 发表于 2021-10-12 08:38
您好，大神，我想请教一下如果想加一下当表格隐藏的时候忽略汇总数据，请问要加在哪里呢，我试了几个位置 ...

大概是这样吧
Sub 汇总()
Dim ARR(1 To 999, 1 To 8)
Set Sh = Sheets("加工明细表")
R = Sh.[A65536].End(3).Row
For I = 2 To Sheets.Count
    With Sheets(I)
       If .Visible = -1 Then
     ******************
       End If
    End With
Next
Sh.Cells(R + 1, 1).Resize(999, 8) = ARR
End Sub

sulli112

半百 发表于 2021-10-12 11:04
大概是这样吧
Sub 汇总()
Dim ARR(1 To 999, 1 To 8)

可以啦，谢谢

sulli112

1. Sub 汇总()
   
2. Dim ARR(1 To 999, 1 To 8)
   
3. Set Sh = Sheets("加工明细表")
   
4. R = Sh.[A65536].End(3).Row
   
5. For I = 2 To Sheets.Count
   
6.      With Sheets(I)
   
7.   If .Visible = -1 Then
   
8.      S = Mid(.[A5], 7)
   
9.          If Len(S) > 0 Then
   
10.              BRR = .Range("A8:G100")
    
11.              For J = 1 To UBound(BRR)
    
12.                  If BRR(J, 2) <> "" Then
    
13.                      N = N + 1
    
14.                      ARR(N, 1) = S
    
15.                      ARR(N, 2) = .[F6]
    
16.                      ARR(N, 3) = .[F5]
    
17.                          For K = 4 To 8
    
18.                          ARR(N, K) = BRR(J, K - 3)
    
19.                          Next
    
20.                      Sh.Cells(N + R, 11) = BRR(J, 7)
    
21.                  Else
    
22.                      Exit For
    
23.                  End If
    
24.              Next
    
25.          End If
    
26.          End If
    
27.      End With
    
28. Next
    
29. Sh.Cells(R + 1, 1).Resize(999, 8) = ARR
    
30. End Sub

复制代码

sulli112

1. Sub 汇总()
   
2. Dim ARR(1 To 999, 1 To 8)
   
3. Set Sh = Sheets("加工明细表")
   
4. R = Sh.[A65536].End(3).Row
   
5. For I = 2 To Sheets.Count
   
6.      With Sheets(I)
   
7.    If .Visible = -1 Then
   
8.      S = Mid(.[A5], 7)
   
9.          If Len(S) > 0 Then
   
10.              BRR = .Range("A8:G100")
    
11.              For J = 1 To UBound(BRR)
    
12.                  If BRR(J, 2) <> "" Then
    
13.                      N = N + 1
    
14.                      ARR(N, 1) = S
    
15.                      ARR(N, 2) = .[F6]
    
16.                      ARR(N, 3) = .[F5]
    
17.                          For K = 4 To 8
    
18.                          ARR(N, K) = BRR(J, K - 3)
    
19.                          Next
    
20.                      Sh.Cells(N + R, 11) = BRR(J, 7)
    
21.                  Else
    
22.                      Exit For
    
23.                  End If
    
24.              Next
    
25.          End If
    
26. End If
    
27.      End With
    
28. Next
    
29. Sh.Cells(R + 1, 1).Resize(999, 8) = ARR
    
30. End Sub

复制代码