Kubi

回復 1# iceandy6150
請參考

1. Private Sub CommandButton1_Click()
   
2.     Dim arr
   
3.     Dim brr()
   
4.     Dim d As Object
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     ar = Array("資料.xlsx", "尺寸.xlsx")
   
8.     For Each book In ar
   
9.         Workbooks.Open ThisWorkbook.Path & "\" & book
   
10.         arr = ActiveSheet.[A1].CurrentRegion
    
11.         ActiveWorkbook.Close 0
    
12.         For i = 2 To UBound(arr)
    
13.             For j = 2 To UBound(arr, 2)
    
14.                 d(arr(i, 1) & arr(1, j)) = arr(i, j)
    
15.             Next j
    
16.         Next i
    
17.     Next book
    
18.     arr = ActiveSheet.[A1].CurrentRegion
    
19.     ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 1)
    
20.     For i = 2 To UBound(arr)
    
21.         For j = 2 To UBound(arr, 2)
    
22.             brr(i - 1, j - 1) = d(arr(i, 1) & arr(1, j))
    
23.         Next j
    
24.     Next i
    
25.     [B2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
26.     Application.ScreenUpdating = True
    
27.     Erase brr
    
28.     Set d = Nothing
    
29.     arr = ""
    
30. End Sub

複製代碼

注意：本程式會自動開啟兩個資料檔來比對，因此執行前不需先開啟資料檔案。