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

sulli112

如图所示，在除表名为加工明细表外，将每个表格的数据填到黄色标题的下面，注意单据编号是合并单元格，直接复制会覆盖了旁边订单号的数据，复制工作表数据的时候要注意提取对应数据的标题可能有横竖排列，会比较不好操作，如果.Visible = xlSheetHidden的时候则忽略不复制数据，谢谢，要提取数据的表格样式图片附件，谢谢！！！！！！！

于箱长

是这样的？第四行涂黄的是你的示例

于箱长

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 <> "加工明细表" 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("加工明细表").[a5].Resize(UBound(Brr), 8) = Brr
    
25. Sheets("加工明细表").[k5].Resize(UBound(Brr), 1) = Application.Index(Brr, , 11)
    
26. MsgBox "完成"
    
27. End Sub
    

复制代码

仅供参考

半百

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)
    S = Mid(.[A5], 7)
        If Len(S) > 0 Then
            BRR = .Range("A8:G100")
            For J = 1 To UBound(BRR)
                If BRR(J, 2) <> "" Then
                    N = N + 1
                    ARR(N, 1) = S
                    ARR(N, 2) = .[F6]
                    ARR(N, 3) = .[F5]
                        For K = 4 To 8
                        ARR(N, K) = BRR(J, K - 3)
                        Next
                    Sh.Cells(N + R, 11) = BRR(J, 7)
                Else
                    Exit For
                End If
            Next
        End If
    End With
Next
Sh.Cells(R + 1, 1).Resize(999, 8) = ARR
End Sub

sulli112

于箱长 发表于 2021-10-11 15:25
是这样的？第四行涂黄的是你的示例

涂黄色是我列示的

sulli112

于箱长 发表于 2021-10-11 15:25
是这样的？第四行涂黄的是你的示例

是我想要的效果

于箱长

sulli112 发表于 2021-10-11 16:15
是我想要的效果

你那花留着是嘎哈用的，送两朵中不中？

sulli112

于箱长 发表于 2021-10-11 16:20
你那花留着是嘎哈用的，送两朵中不中？

我没有看到有附件上传

sulli112

于箱长 发表于 2021-10-11 15:29
仅供参考

谢谢啦，现在才看到

sulli112

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

谢谢啦