[發問] 重新排序

cowww

請問論壇的大大們
以下是長官的需求

下面是從公司打卡系統撈出來的excel檔

下載 (44.54 KB)

2023-5-26 08:16

長官希望可以做成底下的排序
第一個排序我無法使用樞紐完成，請問是否可以用VBA來完成??

下載 (10.47 KB)

2023-5-26 08:16

第二個排序可以用樞紐完成
只是我記得在論壇上好像有看過有人教導使用VBA去完成(臨時要用卻又找不到)


2023國假.zip (214.81 KB)

下載次數: 11

2023-5-26 08:22

Andy2483

回復 1# cowww


    謝謝論壇,謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

執行結果:

下載 (105.08 KB)

2023-5-26 09:22

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

回復 2# Andy2483


非常感謝Andy2483大大的解惑

請問有辦法改成這樣嗎??

下載 (30.91 KB)

2023-5-26 09:58

Andy2483

回復 3# cowww


    謝謝前輩回復
前輩的截圖裡每位職員請假明細只有國假,其它假別如何處理?
產出的報表 實際用途是做什麼用的?

cowww

回復 4# Andy2483

目前只要國假就好
這張表示要給OP看得
OP人數很多
如果放在同一欄的話，印出來的紙張就會非常的長
所以長官才會問能不能做成一列一列的方式

如果可以的話
我希望可以加個下拉式選單來選擇休假的原因
因為我覺得長官可能會提出類似的問題

Andy2483

回復 5# cowww


    綜合方式,請前輩參考

執行結果:

下載 (203.48 KB)

2023-5-26 11:51

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("工作表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) = "工號": Crr(1, 2) = "姓名 | 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("工作表1")
   .Columns(1).NumberFormatLocal = "@": .[A1].Resize(N, UBound(Crr, 2)) = Crr
End With
Set Y = Nothing: Erase Arr, Brr, Crr
End Sub

cowww

回復 6# Andy2483

非常感謝Andy2483大大的解惑

下載 (31.66 KB)

2023-5-26 13:12

為何長官要求要做成跟上面那張表一樣
主要是因為現場的作業員多半都是50歲以上的姊姊們
第一
她們的視力不是很好
第二
她們除了會滑滑手機看影片以外，幾乎沒有資訊能力

所以Andy2483大大呈現出來的樣式
她們一定會生氣的

Andy2483

回復 7# cowww


    用前一方案稍改,先參考

執行結果:

下載 (371.27 KB)

2023-5-26 14:03

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("工作表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 4)
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: R = Y(TT)
   Crr(R, 4) = Crr(R, 4) & "█" & T4: Crr(N, 3) = Crr(N, 3) + 1
i01: Next
With Sheets("工作表1")
   .Columns(1).NumberFormatLocal = "@": .[A1].Resize(N, 4) = Crr
End With
Set Y = Nothing: Erase Brr, Crr
End Sub

Andy2483

回復 7# cowww


    謝謝前輩
後學藉這主題練習多種方案,以下是學習方案,請前輩參考

執行結果:

下載 (400.27 KB)

2023-5-26 14:32

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

回復 9# Andy2483

Andy2483大大真是太強了
剛剛有請幾位姐姐們看了一下
頂多就是字體需要在幫忙放大+粗體(請助理自己處理了)
目前沒聽到任何哀怨聲

非常感謝Andy2483大大的解惑