用VBA 提取同文件夹内相同Excel sheet 固定的数据到汇总表

xiangye30520

求助大神，如附件，想通过VBA抓取同文件夹内 相同Excel sheet（基本信息&商品信息）中固定位置的数据，如图片所示  申报日期  报关单号  商品编号 商品名称 成交数量 总价的数据，其中 (商品编号 商品名称 成交数量 总价)往下循环到100单位，万分感谢！

小凡、、、

gwjkkkkk

Option Explicit
Sub TEST7()
    Dim ar, br, i&, j&, r&, dic As Object, t#
    Dim strPath$, strFileName$, iPosCol&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    t = Timer
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To 10 ^ 4, 1 To UBound(ar, 2)) As String
    For j = 1 To UBound(br, 2)
        br(1, j) = ar(1, j)
        If j > 3 Then dic(br(1, j)) = j
    Next j
    r = 1

    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xls")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With Workbooks.Open(strPath & strFileName)
                ar = Worksheets(1).[A22].CurrentRegion.Value
                For i = 2 To UBound(ar)
                    r = r + 1
                    For j = 1 To UBound(ar)
                        If dic(ar(1, j)) Then
                            iPosCol = dic(ar(1, j))
                            br(r, iPosCol) = ar(i, j)
                        End If
                    Next j
                    br(r, 1) = r - 1
                    br(r, 2) = Worksheets(1).Range("H6").Value
                    br(r, 3) = Worksheets(1).Range("D20").Value
                Next i
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    Cells.Clear
    [A1].Resize(r, UBound(br, 2)) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

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

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.30
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     b = [{3,5,7,10}]
   
7.     ReDim brr(1 To 10000, 1 To 7)
   
8.     On Error Resume Next
   
9.     For Each f In fso.GetFolder(p).Files
   
10.         If LCase$(f.Name) Like "*.xls*" Then
    
11.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
12.                 fn = fso.GetBaseName(f)
    
13.                 Set wb = Workbooks.Open(f, 0)
    
14.                 With wb.Sheets(1)
    
15.                     r = .Cells(Rows.Count, 3).End(3).Row
    
16.                     rq = .[h6].Value
    
17.                     dh = .[d20].Value
    
18.                     arr = .UsedRange
    
19.                     wb.Close False
    
20.                 End With
    
21.                 For i = 23 To UBound(arr)
    
22.                     m = m + 1
    
23.                     brr(m, 1) = m
    
24.                     brr(m, 2) = rq
    
25.                     brr(m, 3) = dh
    
26.                     For j = 1 To UBound(b)
    
27.                         brr(m, j + 3) = arr(i, b(j))
    
28.                     Next
    
29.                 Next
    
30.             End If
    
31.         End If
    
32.     Next f
    
33.     With sh
    
34.         .UsedRange.Offset(1).ClearContents
    
35.         .Columns(3).NumberFormatLocal = "@"
    
36.         With .[a2].Resize(m, 7)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.         End With
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    

复制代码

xiangye30520

小凡、、、 发表于 2024-7-30 19:01

感谢老师的求助，谢谢。

xiangye30520

gwjkkkkk 发表于 2024-7-30 19:45
Option Explicit
Sub TEST7()
    Dim ar, br, i&, j&, r&, dic As Object, t#

受益匪浅啊   学习了

xiangye30520

ykcbf1100 发表于 2024-7-30 20:45
参与一下。。。

老师  这种写法很飘逸啊 厉害

xiangye30520

小凡、、、 发表于 2024-7-30 19:01

凡老师，您的代码写法对于初学着来说，好理解啊，牛，