提取多个不定行工作薄的指定位置的数据，到新的工作表。

zhao11256

求助：将多个工作薄的指定位置数据提取到此新工作表中，将文件夹中工作薄名称E***提取到此工作表第一列，工作薄中“境外收发货人名称（外文）”提取到此工作表第二列，工作薄中“合同协议号”提取到此工作表第三列，工作薄中“商品名称”提取到此工作表第四列， 商品名称行数不定，工作薄中“成交数量”提取到此工作表第五列， 数量行数不定

excel玉米

wang-way

zhao11256

excel玉米 发表于 2024-1-5 13:01

太厉害了，谢谢，谢谢

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.5
   
2.     Dim arr, brr(1 To 10000, 1 To 5)
   
3.     Set Fso = CreateObject("scripting.filesystemobject")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     For Each f In Fso.GetFolder(p).Files
   
8.         If f.Name Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 Set Wb = Workbooks.Open(f, 0)
    
11.                 With Wb.Sheets("基本信息&商品信息")
    
12.                     arr = .UsedRange
    
13.                     r = .Cells(Rows.Count, 1).End(3).Row
    
14.                     p1 = .[d4]
    
15.                     p2 = .[j2]
    
16.                     Wb.Close False
    
17.                 End With
    
18.                 For i = 23 To UBound(arr)
    
19.                     If Val(arr(i, 1)) Then
    
20.                         m = m + 1
    
21.                         brr(m, 1) = arr(i, 3)
    
22.                         brr(m, 2) = p1
    
23.                         brr(m, 3) = p2
    
24.                         brr(m, 4) = arr(i, 5)
    
25.                         brr(m, 5) = Val(arr(i, 7))
    
26.                     End If
    
27.                 Next
    
28.             End If
    
29.         End If
    
30.     Next f
    
31.     With sh
    
32.         .[a2:e10000] = ""
    
33.         .[a2].Resize(m, 5) = brr
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

ykcbf1100

附件供参考。。。