- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
¦^´_ 5# cowww
ºî¦X¤è¦¡,½Ð«e½ú°Ñ¦Ò
°õ¦æµ²ªG:
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Arr, Brr, Crr, V, A, Y, R&, i&, j%, TT$, T1$, T3$, T4 As Date, T9$, N&
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
With Sheets("¤u§@ªí1").[A1].Resize(UBound(Brr), UBound(Brr, 2))
.Columns(1).NumberFormatLocal = "@"
.Value = Brr
.Sort KEY1:=.Item(1), Order1:=1, Key2:=.Item(4), Order2:=1, Header:=2
Brr = .Value: .ClearContents
For i = 1 To UBound(Brr): Y(Brr(i, 9)) = Y(Brr(i, 9)) + 1: Next: V = Y.keys()
.Item(1).Resize(Y.Count, 1) = Application.Transpose(Y.items)
.Item(2).Resize(Y.Count, 1) = Application.Transpose(Y.keys)
.Sort KEY1:=.Item(1), Order1:=2, Key2:=.Item(2), Order2:=1, Header:=2
Arr = .Item(1).CurrentRegion: .ClearContents
Y.RemoveAll
End With
ReDim Crr(1 To UBound(Brr), 1 To UBound(Arr) + 3)
For i = 1 To UBound(Brr)
If i = 1 Then
Crr(1, 1) = "¤u¸¹": Crr(1, 2) = "©m¦W | Display Name": Crr(1, 3) = "¤Ñ¼Æ": N = 1
For j = 1 To UBound(Arr): Crr(1, j + 3) = Arr(j, 2): Y(Arr(j, 2)) = j + 3: Next
End If
T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: R = Y(TT)
Crr(R, Y(T9)) = Trim(Crr(R, Y(T9)) & " " & T4): Crr(N, 3) = Crr(N, 3) + 1
Next
With Sheets("¤u§@ªí1")
.Columns(1).NumberFormatLocal = "@": .[A1].Resize(N, UBound(Crr, 2)) = Crr
End With
Set Y = Nothing: Erase Arr, Brr, Crr
End Sub |
|