|
本帖最后由 cutecpu 于 2021-2-14 15:47 编辑
Sub demo()
clear
Dim month
month = Range("I1").Value
Set d = CreateObject("scripting.dictionary")
orr = Sheets(month & "月其他收入").[a1].CurrentRegion
For i = 6 To UBound(orr)
d(orr(i, 5)) = i
Next
arr = Sheets(month & "月工資").[a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
ReDim crr(1 To UBound(arr), 1 To 5)
ReDim drr(1 To UBound(arr), 1 To 4)
For i = 5 To UBound(arr)
If arr(i, 4) <> "遺屬" Then
r = r + 1
Key = arr(i, 2)
brr(r, 1) = Key
brr(r, 2) = arr(i, 3)
brr(r, 3) = arr(i, 5)
crr(r, 1) = arr(i, 8)
crr(r, 2) = arr(i, 9)
crr(r, 3) = arr(i, 6)
crr(r, 4) = arr(i, 7)
crr(r, 5) = arr(i, 10)
drr(r, 1) = "": drr(r, 2) = "": drr(r, 3) = "": drr(r, 4) = ""
If d.exists(Key) Then
drr(r, 1) = orr(d(Key), 7)
drr(r, 2) = orr(d(Key), 8)
drr(r, 3) = orr(d(Key), 9)
drr(r, 4) = orr(d(Key), 10)
d.Remove arr(i, 2)
End If
Else
Exit For
End If
Next
[D7].Resize(r, 3) = brr
[Y7].Resize(r, 5) = crr
[G7].Resize(r, 4) = drr
ReDim Err(1 To d.Count(), 1 To 3)
ReDim frr(1 To d.Count(), 1 To 4)
For Each Key In d.keys()
rr = rr + 1
Err(rr, 1) = orr(d(Key), 5)
Err(rr, 2) = orr(d(Key), 4)
frr(rr, 1) = orr(d(Key), 7)
frr(rr, 2) = orr(d(Key), 8)
frr(rr, 3) = orr(d(Key), 9)
frr(rr, 4) = orr(d(Key), 10)
Next
Range("D" & 7 + r).Resize(rr, 3) = Err
Range("G" & 7 + r).Resize(rr, 4) = frr
End Sub
Sub clear()
lastRow = Range("D65536").End(xlUp).Row
If lastRow < 7 Then lastRow = 7
Range("D7:P" & lastRow & ",Y7:AC" & lastRow).ClearContents
End Sub
祝順心,南無阿彌陀佛!
|
|