VBA跨文件引用数据

天真无鞋

麻烦那位老师帮忙写个跨文件引用数据，由于引用数据表含公式，引用后的数据为数值，详见附件信息。

ykcbf1100

你这个是真的麻烦，难怪别人不愿意写。同一个字段，字段名有英文、有中文，还有中文和英文结合，都不统一的，二个文件，里面的表名也不同，提取到查询工作簿中，还得分开写数据。
我写了大部分了，最后还是想放弃。

ykcbf1100

你试一下吧，太复杂了，没仔细核对。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.29
   
2.     Application.ScreenUpdating = False
   
3.     Dim fns As New Collection
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set sh = ThisWorkbook.Sheets("FQC data entry")
   
8.     st = sh.[b5].Value
   
9.     If st = Empty Then Exit Sub
   
10.     a = [{"All RMA","All NSR"}]
    
11.     b = [{"Total RMAs list ","NSR List"}]
    
12.     aa = [{"RMA#","日期","客户","产品型号","坏因代码","不符合描述(中文)","状态"}]
    
13.     bb = [{"RMA No","日期","客户","产品型号","Failure code reported","不符合描述(中文)","status"}]
    
14.     aa1 = [{"NSR编号","开单日期","产品型号","拉别&组","坏因代码","不符合描述(中文)","状态"}]
    
15.     bb1 = [{"编号","开单日期","产品型号","拉别&组","坏因代码","不符合描述(中文)","状态"}]
    
16.     ReDim brr(1 To 1000, 1 To UBound(aa) + 1)
    
17.     ReDim crr(1 To 1000, 1 To UBound(aa1) + 1)
    
18.     For x = 1 To UBound(a)
    
19.         d(a(x)) = b(x)
    
20.     Next
    
21.     For x = 1 To UBound(aa)
    
22.         d(aa(x)) = bb(x)
    
23.     Next
    
24.     For x = 1 To UBound(aa1)
    
25.         d(aa1(x)) = bb1(x)
    
26.     Next
    
27.     Set ff = fso.GetFolder(p)
    
28.     getFiles ff, fns, fso
    
29.     On Error Resume Next
    
30.     For Each f In fns
    
31.         bm = d(f(1))
    
32.         Set wb = Workbooks.Open(f(0), 0)
    
33.         Set sht = wb.Sheets(bm)
    
34.         With sht
    
35.             arr = .UsedRange
    
36.             c = .Rows(2).Find("产品型号", , , , , 1).Column
    
37.         End With
    
38.         wb.Close False
    
39.         m = 0: n = 0
    
40.         If f(1) = a(1) Then
    
41.             For i = 3 To UBound(arr)
    
42.                 If InStr(arr(i, c), st) Then
    
43.                     m = m + 1
    
44.                     For x = 1 To UBound(aa)
    
45.                         For j = 1 To UBound(arr, 2)
    
46.                             If arr(2, j) = bb(x) Then
    
47.                                 brr(m, x) = arr(i, j)
    
48.                             End If
    
49.                         Next
    
50.                     Next
    
51.                 End If
    
52.             Next
    
53.         Else
    
54.             For i = 3 To UBound(arr)
    
55.                 If InStr(arr(i, c), st) Then
    
56.                     n = n + 1
    
57.                     For x = 1 To UBound(aa1)
    
58.                         For j = 1 To UBound(arr, 2)
    
59.                             If arr(2, j) = bb1(x) Then
    
60.                                 crr(n, x) = arr(i, j)
    
61.                             End If
    
62.                         Next
    
63.                     Next
    
64.                 End If
    
65.             Next
    
66.         End If
    
67.     Next
    
68.     With sh
    
69.         .[a12:z1000] = ""
    
70.         .[a12].Resize(m, UBound(aa)) = brr
    
71.         .[a12].Resize(m, UBound(aa)).Borders.LineStyle = 1
    
72.         .[i12].Resize(n, UBound(aa1)) = crr
    
73.         .[i12].Resize(n, UBound(aa1)).Borders.LineStyle = 1
    
74.     End With
    
75.     Set d = Nothing
    
76.     MsgBox "OK！"
    
77. End Sub

复制代码

天真无鞋

ykcbf1100 发表于 2024-4-29 13:37
你试一下吧，太复杂了，没仔细核对。

是这样的，谢谢！