遍历提取

ddz79101

老师！有多表，我希望提取各表中发票号码和企业名称，集于1表。请老师帮忙看看。谢谢

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, i&, r&, wks As Worksheet
   
    Application.ScreenUpdating = False
   
    ReDim ar(1 To Worksheets.Count, 1 To 3) As String
    ar(1, 1) = "序号": ar(1, 2) = "发票号码": ar(1, 3) = "名称"
    r = 1
   
    With Worksheets("汇总")
        For Each wks In Worksheets
            If wks.Name <> .Name Then
                r = r + 1
                ar(r, 1) = Format(r, "00")
                ar(r, 2) = wks.[B1].Value
                ar(r, 3) = wks.[B3].Value
            End If
        Next
        .[A1].CurrentRegion.Clear
        .[A1].Resize(r, 3) = ar
        .Activate
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

................

saghj

ddz79101

gwjkkkkk 发表于 2024-6-29 15:41
................

谢谢老师！结果正确

ddz79101

saghj 发表于 2024-6-29 16:02

谢谢老师！结果正确！

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.29
   
2.     Dim brr(1 To 1000, 1 To 3)
   
3.     For Each sht In Sheets
   
4.         If Val(sht.Name) Then
   
5.             m = m + 1
   
6.             brr(m, 1) = Format(m, "00")
   
7.             With sht
   
8.                 r = .Cells(Rows.Count, 1).End(3).Row
   
9.                 For i = 1 To r
   
10.                     If InStr(.Cells(i, 1), "发票号码") Then brr(m, 2) = .Cells(i, 2)
    
11.                     If InStr(.Cells(i, 1), "名称：") Then brr(m, 3) = .Cells(i, 2)
    
12.                 Next
    
13.             End With
    
14.         End If
    
15.     Next
    
16.     With Sheets("汇总")
    
17.         .[a2:c1000] = ""
    
18.         .Columns("A:B").NumberFormatLocal = "@"
    
19.         .[a2].Resize(m, 3) = brr
    
20.     End With
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码