重新排序
請問論壇的大大們以下是長官的需求
下面是從公司打卡系統撈出來的excel檔
[attach]36440[/attach]
長官希望可以做成底下的排序
第一個排序我無法使用樞紐完成,請問是否可以用VBA來完成??
[attach]36442[/attach]
第二個排序可以用樞紐完成
只是我記得在論壇上好像有看過有人教導使用VBA去完成(臨時要用卻又找不到)
[attach]36442[/attach]
[attach]36443[/attach] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121307&ptid=24004]1#[/url] [i]cowww[/i] [/b]
謝謝論壇,謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考
執行結果:
[attach]36444[/attach]
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121308&ptid=24004]2#[/url] [i]Andy2483[/i] [/b]
非常感謝Andy2483大大的解惑
請問有辦法改成這樣嗎??
[attach]36445[/attach] [i=s] 本帖最後由 Andy2483 於 2023-5-26 10:15 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121309&ptid=24004]3#[/url] [i]cowww[/i] [/b]
謝謝前輩回復
前輩的截圖裡每位職員請假明細只有國假,其它假別如何處理?
產出的報表 實際用途是做什麼用的? [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121310&ptid=24004]4#[/url] [i]Andy2483[/i] [/b]
目前只要國假就好
這張表示要給OP看得
OP人數很多
如果放在同一欄的話,印出來的紙張就會非常的長
所以長官才會問能不能做成一列一列的方式
如果可以的話
我希望可以加個下拉式選單來選擇休假的原因
因為我覺得長官可能會提出類似的問題 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121311&ptid=24004]5#[/url] [i]cowww[/i] [/b]
綜合方式,請前輩參考
執行結果:
[attach]36446[/attach]
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121312&ptid=24004]6#[/url] [i]Andy2483[/i] [/b]
非常感謝Andy2483大大的解惑
[attach]36447[/attach]
為何長官要求要做成跟上面那張表一樣
主要是因為現場的作業員多半都是50歲以上的姊姊們
第一
她們的視力不是很好
第二
她們除了會滑滑手機看影片以外,幾乎沒有資訊能力
所以Andy2483大大呈現出來的樣式
她們一定會生氣的 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121313&ptid=24004]7#[/url] [i]cowww[/i] [/b]
用前一方案稍改,先參考
執行結果:
[attach]36450[/attach]
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121313&ptid=24004]7#[/url] [i]cowww[/i] [/b]
謝謝前輩
後學藉這主題練習多種方案,以下是學習方案,請前輩參考
執行結果:
[attach]36451[/attach]
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121316&ptid=24004]9#[/url] [i]Andy2483[/i] [/b]
Andy2483大大真是太強了
剛剛有請幾位姐姐們看了一下
頂多就是字體需要在幫忙放大+粗體(請助理自己處理了)
目前沒聽到任何哀怨聲
非常感謝Andy2483大大的解惑 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121317&ptid=24004]10#[/url] [i]cowww[/i] [/b]
謝謝前輩回復,感覺前輩上班樂在其中 [i=s] 本帖最後由 Andy2483 於 2023-5-26 16:34 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121317&ptid=24004]10#[/url] [i]cowww[/i] [/b]
謝謝論壇,謝謝前輩一起學習
後學藉此帖練習陣列與字典,將排序放到最後,方案與心得註解如下,請前輩參考,一起學習
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%
[color=SeaGreen]'↑宣告變數[/color]
Set Y = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令Y變數是 字典[/color]
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
[color=SeaGreen]'↑令Brr變數是 二維陣列,以儲存格值帶入陣列中[/color]
ReDim Crr(1 To UBound(Brr), 1 To 100)
[color=SeaGreen]'↑宣告Crr變數是 二維空陣列,縱向範圍同Brr陣列,橫向1~100[/color]
For i = 1 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
If i = 1 Then
Crr(1, 1) = "工號": Crr(1, 2) = "姓名 | Display Name": Crr(1, 3) = "天數": N = 1
End If
[color=SeaGreen] '↑如果處理第1列時,特別先處理結果表的標題列[/color]
T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
[color=SeaGreen] '↑令陣列值以變數盛裝,可定義變數類型,又可精簡程式碼[/color]
If T9 <> "國假" Then GoTo i01
[color=SeaGreen] '↑如果假別不是 "國假" 就不處理跳過[/color]
If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: Y(TT & "|C") = 3
[color=SeaGreen] '↑如果關鍵字是初次納入字典,必須先處理標題欄[/color]
R = Y(TT): C = Y(TT & "|C"): C = C + 1: Y(TT & "|C") = C: If MC < C Then MC = C
[color=SeaGreen] '↑將字典中紀錄的欄位,列位提取出來,並判定最後寫入儲存格時的欄數MC[/color]
Crr(R, C) = T4: Crr(R, 3) = Crr(R, 3) + 1
[color=SeaGreen] '↑將新日期放入Crr陣列中,天數要累加[/color]
i01: Next
For i = 4 To MC: Crr(1, i) = i - 3: Next
[color=SeaGreen]'↑將標題列天數填入[/color]
With Sheets("工作表1")
.UsedRange.ClearContents
[color=SeaGreen] '↑清除結果表內容[/color]
.Columns(1).NumberFormatLocal = "@"
[color=SeaGreen] '↑令結果表第1欄格式是文字[/color]
.Rows(1).NumberFormatLocal = "@"
[color=SeaGreen] '↑令結果表第1列格式是文字[/color]
With .[A1].Resize(N, MC)
.Value = Crr
[color=SeaGreen] '↑令Crr陣列值寫入結果表中[/color]
.Sort KEY1:=.Item(1), Order1:=1, Header:=1
[color=SeaGreen] '↑令該範圍儲存格以第1欄為基準,做有標題列的順排序[/color]
End With
End With
Set Y = Nothing: Erase Brr, Crr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub
=============================================
補充:
.Columns(1).NumberFormatLocal = "@"
.Rows(1).NumberFormatLocal = "@"
可合併為:
Union(.Columns(1), .Rows(1)).NumberFormatLocal = "@" [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121319&ptid=24004]12#[/url] [i]Andy2483[/i] [/b]
非常感謝Andy2483大大的熱心解惑
這段語法無法執行
請問這段語法跟#9的語法有何不同 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121319&ptid=24004]12#[/url] [i]Andy2483[/i] [/b]
忘記將錯誤訊息發上來了
[attach]36458[/attach]
[attach]36459[/attach] [i=s] 本帖最後由 Andy2483 於 2023-5-29 11:59 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121327&ptid=24004]14#[/url] [i]cowww[/i] [/b]
謝謝前輩回復
1.資料表表名是 sheet1,請查看資料表表明是否更改
2.資料表欄位是否變動
3.再不行,請上傳範例檔
Brr = Range([[color=Black][b]sheet1[/b][/color]!I3], [[b]sheet1[/b]!A65536].End(3))
'↑令Brr變數是 二維陣列,以儲存格值帶入陣列中 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121328&ptid=24004]15#[/url] [i]Andy2483[/i] [/b]
非常感謝Andy2483大大的幫忙
[attach]36461[/attach]
[attach]36462[/attach]
[attach]36463[/attach]
裡面有我正在練習的下拉式選單的聯動 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121329&ptid=24004]16#[/url] [i]cowww[/i] [/b]
If T9 <> "國假" Then GoTo i01
改成
If T9 <> "National Holiday" Then GoTo i01 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121331&ptid=24004]17#[/url] [i]Andy2483[/i] [/b]
成功了
非常感謝Andy2483大大的解惑 謝謝論壇,謝謝各位前輩
後學藉此帖複習直式呈現方式,方案學習心得註解如下,請各位前輩指教
[attach]36466[/attach]
Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 2), A, Y, R&, i&, TT$, T1$, T3$, T4 As Date, T9$
[color=SeaGreen]'↑宣告變數[/color]
Set Y = CreateObject("Scripting.Dictionary")
[color=SeaGreen]'↑令Y變數是 字典[/color]
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
[color=SeaGreen]'↑令Brr變數是 二維陣列,以sheet1 表的A~I欄儲存格值帶入陣列中[/color]
With Sheets("工作表1").[A2].Resize(UBound(Brr), UBound(Brr, 2))
[color=SeaGreen]'↑以下是關於名為 "工作表1" 工作表擴展Brr陣列範圍的程序[/color]
.Value = Brr
[color=SeaGreen] '↑令儲存格值是 Brr陣列值[/color]
.Sort KEY1:=.Item(1), Order1:=1, _
Key2:=.Item(4), Order2:=1, Header:=2
[color=SeaGreen] '↑令該範圍做2層次,無標題列的縱向順排序[/color]
Brr = .Value
[color=SeaGreen] '↑令Brr二維陣列值是該範圍排序後的陣列值[/color]
End With
For i = 1 To UBound(Brr)
[color=SeaGreen]'↑設順迴圈[/color]
T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9)
[color=SeaGreen] '↑令變數裝入陣列值,一方面定義其值,一方面可以縮短程式碼[/color]
If T9 <> "國假" Then GoTo i00
[color=SeaGreen] '↑如果T9變數不是 "國假"字串,就跳到i00位置繼續執行[/color]
TT = T1 & "|" & T3: A = Y(TT)
[color=SeaGreen] '↑令TT變數是 組合字串,令A變數是 以TT變數查Y字典回傳的item[/color]
If Not IsArray(A) Then A = Crr: Y(TT & "/編") = T1: Y(TT & "/名") = T3
[color=SeaGreen] '↑如果item不是陣列?? 就令A變數是Crr陣列(空陣列),
'令TT變數連接 "/編"組成的新字串當key,item是T1變數,納入Y字典裡,
'令TT變數連接 "/名"組成的新字串當key,item是T3變數,納入Y字典裡[/color]
R = Y(TT & "/R"): R = R + 1: Y(TT & "/R") = R
[color=SeaGreen] '↑令R變數是 TT變數連接 "/R"組成的新字串查Y字典的回傳值,
'令R變數累加 1,
'令TT變數連接 "/R"組成的新字串當key,item是 R變數,納入Y字典裡[/color]
A(R, 1) = T4: A(R, 2) = T9: Y(TT) = A
[color=SeaGreen] '↑令R變數列第1欄A陣列值是 T4變數值,令R變數列第2欄A陣列值是 T4變數值,
'令TT變數當key,item是A二維陣列納入Y字典中[/color]
i00: Next
With Sheets("工作表1")
[color=SeaGreen]'↑以下是關於名為 "工作表1" 工作表的程序[/color]
.UsedRange.Offset(1, 0).Clear: R = 1
[color=SeaGreen] '↑令使用的儲存格往下偏移1列範圍的儲存格清除,令R變數是 1[/color]
.Columns(1).NumberFormatLocal = "@"
[color=SeaGreen] '↑令A欄格式是 文字[/color]
For Each A In Y.KEYS
[color=SeaGreen] '↑設逐項迴圈,令A變數是Y字典裡的key[/color]
If Not IsArray(Y(A)) Then GoTo i01
[color=SeaGreen] '↑如果以A變數查Y字典回傳得item不是 陣列,就跳到i01位置執行[/color]
R = R + 1
[color=SeaGreen] '↑令R變數累加1[/color]
.Cells(R, 1) = Y(A & "/編"): .Cells(R, 2) = Y(A & "/名")
[color=SeaGreen] '↑令儲存格寫入 員工編號與姓名[/color]
.Cells(R, 3).Resize(Y(A & "/R"), 2) = Y(A): R = R + Y(A & "/R") - 1
[color=SeaGreen] '↑令適當範圍寫入Y字典所回傳item二維陣列值[/color]
i01: Next
End With
Set Y = Nothing: Erase Brr, Crr
[color=SeaGreen]'↑令釋放變數[/color]
End Sub [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121337&ptid=24004]19#[/url] [i]Andy2483[/i] [/b]
非常感謝Andy2483大大的註解
頁:
[1]