从多个结构相同的表中提取有数据的行，并且自动生成

wlyycb

根据出库单自动提取提货单位，出库日期，品名，规格对应的总支数和重量以及车号这几个信息                              为方便使用公式，表的名字可以改，现在是1,2，是否需要改成表1，表2，或者是sheet1,sheet2

三分醉，七分醒

Option Explicit
Sub 自动提取()
Dim sth As Worksheet
Dim arr, brr()
Dim r As Long, c As Long, count As Long, i As Long
Application.ScreenUpdating = False
For Each sth In Worksheets
    sth.Activate
    If sth.Name <> "汇总表" Then
    r = sth.Range("b4").End(xlDown).Row
    c = sth.Range("v3").End(xlToLeft).Column
        arr = sth.Range("b4", Cells(r, c))
        For i = 1 To UBound(arr)
            count = count + 1
            ReDim Preserve brr(1 To 8, 1 To count)
            brr(1, count) = count
            brr(2, count) = sth.Range("d2")
            brr(3, count) = sth.Range("o2")
            brr(4, count) = arr(i, 1)
            brr(5, count) = arr(i, 4)
            brr(6, count) = arr(i, 15)
            brr(7, count) = arr(i, 17)
            brr(8, count) = sth.Range("n17")            
        Next
    End If
Next
Sheets("汇总表").Range("a2", "h1000") = ""
Sheets("汇总表").Range("a2").Resize(UBound(brr, 2), UBound(brr)) = WorksheetFunction.Transpose(brr)
Application.ScreenUpdating = True
End Sub

feilanga

''''''''''''''''''''''''''''''''''''''''''''''

wlyycb

feilanga 发表于 2022-9-25 22:15
''''''''''''''''''''''''''''''''''''''''''''''

谢谢，非常感谢您的热心帮助。

wlyycb

三分醉，七分醒 发表于 2022-9-25 21:58
Option Explicit
Sub 自动提取()
Dim sth As Worksheet

谢谢，感谢您的热心帮助和耐心指导。

wlyycb

三分醉，七分醒 发表于 2022-9-25 21:58
Option Explicit
Sub 自动提取()
Dim sth As Worksheet

已经使用了，操作十分流畅，真是高手啊，太佩服您对代码的掌控能力了，再次感谢，愿好人一生平安！

wlyycb

三分醉，七分醒 发表于 2022-9-25 21:58
Option Explicit
Sub 自动提取()
Dim sth As Worksheet

老师，当单据增加的时候，公式出现问题了，不知道怎么解决

wlyycb

三分醉，七分醒 发表于 2022-9-25 21:58
Option Explicit
Sub 自动提取()
Dim sth As Worksheet

当表中有数据的行数改变的时候，采集出现问题

一烟难禁

1. Sub huizong()
   
2. Dim h&, i&, j&, k&, st$, sk$, da As Date
   
3. Dim ra As Range, arr, brr, xx, yy
   
4. Dim ws As Worksheet
   
5. For Each ws In Worksheets
   
6.     If ws.Name <> "汇总表" Then
   
7.         st = ws.Range("d2")
   
8.         da = ws.Range("o2")
   
9.         sk = ws.Range("n17")
   
10.         arr = ws.Range("b4:t15")
    
11.         ReDim brr(1 To 1000, 1 To 7)
    
12.         For i = 1 To UBound(arr)
    
13.             If arr(i, 1) <> "" Then
    
14.                 brr(i, 1) = st
    
15.                 brr(i, 2) = da
    
16.                 brr(i, 3) = arr(i, 1)
    
17.                 brr(i, 4) = arr(i, 4)
    
18.                 brr(i, 5) = arr(i, 15)
    
19.                 brr(i, 6) = arr(i, 17)
    
20.                 brr(i, 7) = sk
    
21.             Else
    
22.                 Exit For
    
23.             End If
    
24.         Next
    
25.     Else
    
26.         Exit For
    
27.     End If
    
28.     h = Sheets("汇总表").Cells(Rows.Count, 2).End(3).Row + 1
    
29.     Sheets("汇总表").Range("b" & h).Resize(UBound(brr), 7) = brr
    
30. Next
    
31. End Sub
    

复制代码

380623488

下不了，啥情况