Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 2), A, Y, R&, i&, TT$, T1$, T3$, T4 As Date, T9$
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
For i = 1 To UBound(Brr)
T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9)
TT = T1 & "|" & T3: A = Y(TT)
If Not IsArray(A) Then A = Crr: Y(TT & "/編") = T1: Y(TT & "/名") = T3
R = Y(TT & "/R"): R = R + 1: Y(TT & "/R") = R:
A(R, 1) = T4: A(R, 2) = T9: Y(TT) = A
Next
With Sheets("工作表1")
.UsedRange.Offset(1, 0).Clear: R = 1
.Columns(1).NumberFormatLocal = "@"
For Each A In Y.KEYS
If Not IsArray(Y(A)) Then GoTo i01
R = R + 1
.Cells(R, 1) = Y(A & "/編"): .Cells(R, 2) = Y(A & "/名")
.Cells(R, 3).Resize(Y(A & "/R"), 2) = Y(A): R = R + Y(A & "/R") - 1
i01: Next
End With
Set Y = Nothing: Erase Brr, Crr
End Sub作者: cowww 時間: 2023-5-26 09:58
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Arr, Brr, Crr, V, A, Y, R&, i&, j%, C%, TT$, T1$, T3$, T4 As Date, T9$, N&, MC%
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
With Sheets("工作表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: Sheets("工作表1").UsedRange.ClearContents
End With
ReDim Crr(1 To UBound(Brr), 1 To 100)
For i = 1 To UBound(Brr)
If i = 1 Then
Crr(1, 1) = "工號": Crr(1, 2) = "姓名 | Display Name": Crr(1, 3) = "天數": N = 1
End If
T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
If T9 <> "國假" Then GoTo i01
If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: Y(TT & "|C") = 3
R = Y(TT): C = Y(TT & "|C"): C = C + 1: Y(TT & "|C") = C: If MC < C Then MC = C
Crr(R, C) = T4: Crr(N, 3) = Crr(N, 3) + 1
i01: Next
For i = 4 To MC: Crr(1, i) = i - 3: Next
With Sheets("工作表1")
.Rows(1).NumberFormatLocal = "@": .[A1].Resize(N, MC) = Crr
End With
Set Y = Nothing: Erase Brr, Crr
End Sub作者: cowww 時間: 2023-5-26 15:17
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr, V, A, Y, R&, i&, j%, C%, TT$, T1$, T3$, T4 As Date, T9$, N&, MC%
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
'↑令Brr變數是 二維陣列,以儲存格值帶入陣列中
ReDim Crr(1 To UBound(Brr), 1 To 100)
'↑宣告Crr變數是 二維空陣列,縱向範圍同Brr陣列,橫向1~100
For i = 1 To UBound(Brr)
'↑設順迴圈
If i = 1 Then
Crr(1, 1) = "工號": Crr(1, 2) = "姓名 | Display Name": Crr(1, 3) = "天數": N = 1
End If
'↑如果處理第1列時,特別先處理結果表的標題列
T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
'↑令陣列值以變數盛裝,可定義變數類型,又可精簡程式碼
If T9 <> "國假" Then GoTo i01
'↑如果假別不是 "國假" 就不處理跳過
If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: Y(TT & "|C") = 3
'↑如果關鍵字是初次納入字典,必須先處理標題欄
R = Y(TT): C = Y(TT & "|C"): C = C + 1: Y(TT & "|C") = C: If MC < C Then MC = C
'↑將字典中紀錄的欄位,列位提取出來,並判定最後寫入儲存格時的欄數MC
Crr(R, C) = T4: Crr(R, 3) = Crr(R, 3) + 1
'↑將新日期放入Crr陣列中,天數要累加
i01: Next
For i = 4 To MC: Crr(1, i) = i - 3: Next
'↑將標題列天數填入
With Sheets("工作表1")
.UsedRange.ClearContents
'↑清除結果表內容
.Columns(1).NumberFormatLocal = "@"
'↑令結果表第1欄格式是文字
.Rows(1).NumberFormatLocal = "@"
'↑令結果表第1列格式是文字
With .[A1].Resize(N, MC)
.Value = Crr
'↑令Crr陣列值寫入結果表中
.Sort KEY1:=.Item(1), Order1:=1, Header:=1
'↑令該範圍儲存格以第1欄為基準,做有標題列的順排序
End With
End With
Set Y = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub
