以下程式碼，目前小弟是以迴圈方式設計，當資料大時跑的速度有點久，不知有其有辦法再簡化或其他方式執行??
sub aa()
Dim sht As Worksheet
For mon = 1 To 12
Application.EnableEvents = False
For Each sht In Worksheets
col = Sheets(mon & "月未結").Range("A1").End(xlToRight).Column
r = Sheets(mon & "月未結").Range("AA1").Value
For x = 7 To col
For y = 2 To r
mony = Application.IfError(Application.VLookup(Sheets(mon & "月未結").Range("A" & y), Sheets("" & sht.Name).Range("A:U"), Application.Match(Sheets("" & sht.Name).Cells(1, x),
Sheets("" & sht.Name).Range("A1:U1"), 0), 0), "")
Sheets(mon & "月未結").Cells(y, x) = mony
Next
Next
End If
Next
Application.EnableEvents = True
Next mon
end sub
Sub test()
Dim Arr, xD, T$, R%, C%, i&, j&
Application.EnableEvents = False
Tm = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([資料來源!k1], [資料來源!a65536].End(3))
For i = 2 To UBound(Arr)
xD(Arr(i, 1)) = 1
For j = 2 To UBound(Arr, 2)
xD(Arr(i, 1) & "_" & Arr(1, j)) = Arr(i, j)
Next
Next
For Each sht In Worksheets
If InStr(sht.Name, "月") Then
With Sheets(sht.Name)
R = .Range("a65536").End(3).Row
C = .Cells(1, Columns.Count).End(xlToLeft).Column
Arr = .Range(.[a1], .Cells(R, C))
For i = 2 To UBound(Arr)
If xD(Arr(i, 1)) = 1 Then
For j = 2 To C
Arr(i, j) = xD(Arr(i, 1) & "_" & Arr(1, j))
Next
End If
Next
.Range("a1").Resize(R, C) = Arr
End With
End If
Next
MsgBox Timer - Tm
Application.EnableEvents = True
End Sub
發表於 2021-9-8 14:29
| 
發表於 2021-9-10 16:24
| 