跨工作簿提取部分列数据

转角处的沉思

求教如何实现打开工作簿B时自动提取其它文件夹下工作簿A内部分列数据，示例见附件。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.22
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With sh
   
6.         col = .UsedRange.Columns.Count
   
7.         For j = 1 To col
   
8.             d(.Cells(1, j).Value) = j
   
9.         Next
   
10.     End With
    
11.     p = ThisWorkbook.Path & ""
    
12.     With Application.FileDialog(msoFileDialogFilePicker)
    
13.         .InitialFileName = p
    
14.         .Title = "请选择对应Excel文件"
    
15.         .AllowMultiSelect = False
    
16.         .Filters.Clear
    
17.         .Filters.Add "Excel文件", "*.xls*"
    
18.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
19.     End With
    
20.     Set wb = Workbooks.Open(f, 0)
    
21.     With wb.Sheets("Sheet1")
    
22.         r = .Cells(Rows.Count, 2).End(3).Row
    
23.         c = .UsedRange.Columns.Count
    
24.         arr = .[a1].Resize(r, c)
    
25.     End With
    
26.     wb.Close 0
    
27.     ReDim brr(1 To 10000, 1 To col)
    
28.     For i = 2 To UBound(arr)
    
29.         m = m + 1
    
30.         For j = 1 To UBound(arr, 2)
    
31.             s = arr(1, j): t = Val(d(s))
    
32.             If t > 0 Then
    
33.                 brr(m, t) = arr(i, j)
    
34.             End If
    
35.         Next
    
36.     Next
    
37.     With sh
    
38.         .UsedRange.Offset(1).ClearContents
    
39.         .[a2].Resize(m, col) = brr
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

转角处的沉思

ykcbf1100 发表于 2024-7-22 09:41
附件供参考。。。

感谢帮助，运行效果佳。