- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2023-9-21
|
回復 5# qaqa3296
資料sheets的資料位置與原來檔案的位置不一樣，修改如下，請再測試看看，謝謝。
Sub test2()
Dim Arr, Ar, Brr(1 To 10000, 1 To 4), xD, T, i&, j%, n%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([查詢!K1], [查詢!A65536].End(3))
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) <> "" Then Ar = Ar & "," & Arr(i, j)
Next
xD(Arr(i, 1) & "") = Mid(Ar, 2): Ar = ""
Next
Arr = Range([查詢2!B1], [查詢2!A65536].End(3))
For i = 2 To UBound(Arr): xD(Arr(i, 1) & "") = Arr(i, 2): Next
Arr = Range([資料!A1], [資料!B65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): n = n + 1
If xD.Exists(T & "") Then
Brr(n, 1) = T: Brr(n, 2) = Arr(i, 2)
Ar = Split(xD(T & ""), ",")
For j = 0 To UBound(Ar)
n = n + 1: Brr(n, 3) = Ar(j)
Brr(n, 4) = xD(Brr(n, 3) & "")
Next
Else
Brr(n, 1) = T: Brr(n, 2) = Arr(i, 2)
End If
Next
Sheets("結果").Range("A2").Resize(n, 4) = Brr
End Sub |
|
發表於 2021-7-5 07:19
| 