麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 橫式資料轉換為直式資料_各梯次名單 [打印本頁]

作者: Andy2483 時間: 2022-12-2 15:32 標題: 橫式資料轉換為直式資料_各梯次名單

本帖最後由 Andy2483 於 2022-12-2 15:38 編輯

各位前輩好
後學想學習各種不同vba寫法,請各位前輩指導!謝謝
後學藉 aer前輩的主題範例作為題材,謝謝 aer前輩,如有冒犯請見諒
不同主題另開題作學習
http://forum.twbts.com/viewthrea ... a=pageD1&page=1
報名轉檔.zip 範例如上論壇鏈結

請將範例處理成為梯次名單(梯次橫向排序,各梯名單各自排序)如下圖
[attach]35554[/attach]

後學的程式碼如下:
Option Explicit
Sub TEST_直式梯次名單()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
.Replace What:=" ", Replacement:="", LookAt:=xlPart
.Sort KEY1:=.Item(1), Order1:=1, Header:=1
Arr = .Value
Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
.Clear
End With
For Each xR In Brr
If Trim(xR) <> "" Then
   S = InStr(xR, "梯") + 1
   N = InStr(xR, "(")
   D = Mid(xR, S, N - S)
   Y(D) = Trim(xR)
End If
Next
[Sheet3!A1].Resize(Y.Count, 1) = Application.Transpose(Y.KEYS)
[Sheet3!B1].Resize(Y.Count, 1) = Application.Transpose(Y.ITEMS)
With Sheets("Sheet3").UsedRange
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
Brr = .Value
.Clear
End With
Y.RemoveAll
For i = 1 To UBound(Brr)
M = M + 1
Y(Brr(i, 2)) = M
Next
ReDim Brr(1 To UBound(Arr), 1 To Y.Count)
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
   If Arr(i, j) <> "" Then
      R = Y(Arr(i, j) & "|")
      R = R + 1
      C = Y(Arr(i, j) & "")
      Brr(R, C) = Arr(i, 1)
      Y(Arr(i, j) & "|") = R
   End If
Next j
Next i
[Sheet3!A1].Resize(1, M) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A2].Resize(UBound(Brr), M) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Arr = Nothing
Set Y = Nothing
End Sub

PS:後學星期六.日不方便回復前輩,請見諒,星期一早上回復

作者: Andy2483 時間: 2022-12-2 16:11

糗了!沒處理重複的名單!
請各位前輩指導!謝謝

作者: hcm19522 時間: 2022-12-3 10:06

https://blog.xuite.net/hcm19522/twblog/590642862

作者: Andy2483 時間: 2022-12-5 11:12

本帖最後由 Andy2483 於 2022-12-5 11:22 編輯

回復 3# hcm19522

謝謝前輩指導 OFFSET() 的用法
[attach]35559[/attach]

後學學習心得如下,請前輩再指導!謝謝
H1=OFFSET($A$1,COLUMN(A1),ROW(A1)-1)&""
令[H1]儲存格的值是:固定標的儲存格[A1] 偏移位置格的值, 再連接空字元的值(以免標空白的目標格,讓結果格值顯示 0)

1.$A$1是一個固定位址的儲存格; $A是固定欄位的意思; $1是列位固定的意思
1.1.其他如 $A1:是欄位固定,列位不固定的意思
1.2.其他如 A$1:是欄位不固定,列位固定的意思
1.3.其他如 A1:是欄位不固定,列位也不固定的意思

2..偏移位置格的值
2.1.[A1]儲存格偏移往下偏移  COLUMN(A1) 列數:[A1]自身的欄位就是 1
2.2.[A1]儲存格偏移往橫向偏移 ROW(A1)-1 欄位:[A1]自身的列位是 1,減掉1變成 0(不偏移的意思)
https://support.microsoft.com/zh-tw/office/offset-%E5%87%BD%E6%95%B8-c8de19ae-dd79-4b9b-a14e-b4d906d11b66
=OFFSET($A$1,0,0)  結果>> 第1梯
=OFFSET($A$1,1,0)  結果>> A1

3.把列位與欄位參數化!讓欄數與列數對調,呈現出想要的值,再[H1]複製到[H1:T5]這些結果格,就會產生轉置的效果

作者: hcm19522 時間: 2022-12-5 12:24

本帖最後由 hcm19522 於 2022-12-5 13:42 編輯

回復 4# Andy2483

學習精神可嘉按個讚

OFFSET(儲存格名稱,上下移動數,左右移動數,上下區間數,左右區間數) 整欄或整列後二參數可省掉

後面 &""-->儲存格若為空則空否則為 0

https://blog.xuite.net/hcm19522/twblog/590645095

作者: Andy2483 時間: 2022-12-6 16:45

本帖最後由 Andy2483 於 2022-12-6 16:54 編輯

今天練習多個字典與陣列,排除資料表重複列_整理成直式梯次名單_方式:先整理再排序
以下是結果,請各位前輩指導!謝謝
邀請大家一起上論壇學習!討論!
執行結果:
[attach]35567[/attach]

PS:有兩個高O芬不同梯次
Option Explicit
Sub TEST_排除資料表重複列_直式梯次名單_先整理再排序()
Dim Brr, Crr, xR, Z, xA, V, W, P, Sh1, SH3
Dim i&, j&, S&, N&, R&, C&, X&, Y&, Q&
Dim D As Date, Da$, T$
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set SH3 = Sheets("Sheet3")
SH3.UsedRange.Clear
Crr = Range(Sh1.[A1], Sh1.UsedRange).Offset(1, 0)
R = UBound(Crr) - 1
C = UBound(Crr, 2)
ReDim Brr(1 To R, 1 To C)
ReDim V(R - 1)
For i = 1 To R
Da = ""
For j = 1 To C
   Da = Da & "/" & Crr(i, j)
Next
If W.Exists(Da) = Empty Then
   Q = Q + 1
   For j = 1 To C
      Brr(Q, j) = Trim(Crr(i, j))
   Next
   W(Da) = ""
End If
Next
W.RemoveAll
For Each xR In Brr
If InStr(xR, "(") Then
   S = InStr(xR, "梯") + 1
   N = InStr(xR, "(")
   D = Mid(xR, S, N - S)
   W(D) = xR
   P(xR) = D
End If
Next
For Each xA In W.KEYS
Z(xA) = V
Next
For i = 1 To Q
For j = 2 To C
   T = Brr(i, j)
   If T <> "" Then
      V = Z(P(T))
      X = W(T & "|") + 1
      V(X - 1) = Brr(i, 1)
      W(T & "|") = X
      Z(P(T)) = V
   End If
Next j
Next i
SH3.[A1].Resize(1, Z.Count) = Application.Transpose(Application.Transpose(Z.KEYS))
SH3.[A2].Resize(Q, Z.Count) = Application.Transpose(Z.ITEMS)
For i = 1 To SH3.UsedRange.Columns.Count
With Range(SH3.Cells(1, i), SH3.Cells(Rows.Count, i).End(3))
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
End With
Next
With SH3.UsedRange
.Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
For i = 1 To .Columns.Count
   D = .Cells(1, i)
   .Cells(1, i) = W(D)
Next
End With
Application.Goto [Sheet3!A1]
Set Crr = Nothing
Set Brr = Nothing
Set W = Nothing
Set Z = Nothing
Set P = Nothing
End Sub

作者: Andy2483 時間: 2022-12-7 16:44

謝謝論壇
今天自己註解程式碼質疑了自己是否真懂每個陳述.涵式...,還是只會抄襲
item() :會依位置或按鍵傳回集合物件的特定成員。
https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/item-method-visual-basic-for-applications
以下是#6樓的心得註解

Option Explicit
Sub TEST_排除資料表重複列_直式梯次名單_先整理再排序()
Dim Brr, Crr, xR, Z, xA, V, W, P, Sh1, SH3
'↑宣告通用型變數
Dim i&, j&, S&, N&, R&, C&, X&, Y&, Q&
'↑宣告長整數變數
Dim D As Date, Da$, T$
'↑宣告變數!(D)是日期變數,(Da,T)是字串變數
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
'↑令W,Z,P各是字典
Set Sh1 = Sheets("Sheet1")
'↑令Sh1是 "Sheet1" 工作表
Set SH3 = Sheets("Sheet3")
'↑令Sh1是 "Sheet3" 工作表
SH3.UsedRange.Clear
'↑令 "Sheet3" 工作表涵蓋有使用的儲存格最小方正區域清除
Crr = Range(Sh1.[A1], Sh1.UsedRange).Offset(1, 0)
'↑令Crr是表1[A1]到有使用儲存格的最小方正範圍儲存格往下偏移1列範圍的值
R = UBound(Crr) - 1
'↑令R是 Crr陣列縱向最大列號數減 1
C = UBound(Crr, 2)
'↑令C是 Crr陣列橫向最大列號數
ReDim Brr(1 To R, 1 To C)
'↑宣告Brr陣列範圍!縱向從1到R,橫向從1到C
ReDim V(R - 1)
'↑宣告V是一維陣列!索引範圍從0到R - 1
For i = 1 To R
'↑設外順迴圈!i從1到R
Da = ""
'↑令Da字串變數是空字元
For j = 1 To C
'↑設內順迴圈!j從1到C
   Da = Da & "/" & Crr(i, j)
   '↑令Da字串變數是自己連接"/"符號,再連接i迴圈列j迴圈欄的Crr陣列值
Next
If W.Exists(Da) = Empty Then
'↑如果以Da當key查察W字典裡是初始值
   Q = Q + 1
   '↑令Q變數累加1
   For j = 1 To C
   '↑設內順迴圈!j從1到C
      Brr(Q, j) = Trim(Crr(i, j))
      '↑令Q變數列第j迴圈欄的Brr陣列值是 i迴圈列第迴圈j欄的值去掉頭尾的空白字元
   Next
   W(Da) = ""
   '↑令以Da字串變數值當key,item是空字元倒入W字典裡
End If
Next
W.RemoveAll
'↑清空W字典
For Each xR In Brr
'↑設順迴圈!令xR 是Brr陣列的一員
If InStr(xR, "(") Then
'↑如果xR值裡有包含"("符號?
   S = InStr(xR, "梯") + 1
   '↑令S是xR判斷 "梯"字元所在字元位置數
   N = InStr(xR, "(")
   '↑令N 是 xR判斷 "("字元所在字元位置數
   D = Mid(xR, S, N - S)
   '↑令D是 xR值從S字元開始取 N - S個字的字串再變為日期
   W(D) = xR
   '↑令D這日期當key,item是xR的值
   P(xR) = D
   '↑令xR這日期當key,item是D的值
End If
Next
For Each xA In W.KEYS
'↑設順迴圈!令xA 是W字典裡keys的一員
Z(xA) = V
'↑令以xA為key,item是V一維陣列,倒入Z字典裡
Next
For i = 1 To Q
'↑設外順迴圈!i從1到Q
For j = 2 To C
'↑設內順迴圈!j從1到Q
   T = Brr(i, j)
   '↑令T字串變數是i迴圈列j迴圈欄的Brr陣列值
   If T <> "" Then
   '↑如果T字串變數不等於空字元??
      V = Z(P(T))
      '↑令V這通用型變數是以T字串查察P字典的item值再查察Z字典得到的item(一維陣列)
      X = W(T & "|") + 1
      '↑令X這數字變數是以T字串連接"|"符號查察字典的item值累加 1
      V(X - 1) = Brr(i, 1)
      '↑令V這一維陣列的索引號是 X-1的元素是是i迴圈列第一欄的Brr陣列值
      W(T & "|") = X
      '↑令以T字串連接"|"符號為key的item是數字變數X
      Z(P(T)) = V
      '↑令以T字串查察P字典的item值再查察Z字典得到的item是一維陣列V
   End If
Next j
Next i
SH3.[A1].Resize(1, Z.Count) = Application.Transpose(Application.Transpose(Z.KEYS))
'↑令表三[A1]擴展向下擴展1列(A1自身列),向右擴展Z字典鍵數欄是 Z字典key轉置兩次的值
SH3.[A2].Resize(Q, Z.Count) = Application.Transpose(Z.ITEMS)
'↑令表三[A2]擴展向下擴展 Q列,向右擴展Z字典鍵數欄是 Z字典key轉置兩次的值
For i = 1 To SH3.UsedRange.Columns.Count
'↑設順迴圈!i從1到表三使用範圍的欄數
With Range(SH3.Cells(1, i), SH3.Cells(Rows.Count, i).End(3))
'↑以下是有關於表三每一欄有內容的儲存格程序
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
   '↑排序:基準是範圍裡第一格欄位,大到小,沒有標題列,縱向排序從上到下
End With
Next
With SH3.UsedRange
'↑以下是有關於表三使用範圍的儲存格程序
.Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
'↑排序:基準是範圍裡第一格列位,大到小,沒有標題列,縱向排序從左到右
For i = 1 To .Columns.Count
'↑設順迴圈!i從1 到表三使用範圍的欄數
   D = .Cells(1, i)
   '↑令D日期變數是表三使用範圍的相對儲存格第1列第i迴圈變數欄的值轉成日期
   .Cells(1, i) = W(D)
   '↑令以表三使用範圍的相對儲存格第1列第i迴圈變數欄的值查察W字典得到的item值(字串)
   '的值放入當格
Next
End With
Application.Goto [Sheet3!A1]
Set Crr = Nothing
Set Brr = Nothing
Set W = Nothing
Set Z = Nothing
Set P = Nothing
End Sub

Sub Item的規則()
Dim Area As Range
Set Area = [A1:J10]
MsgBox Area.Item(1).Address
MsgBox Area.Item(5).Address
MsgBox Area.Item(10).Address
MsgBox Area.Item(11).Address
MsgBox Area.Item(100).Address
MsgBox Area.Item(101).Address
'↑範圍內由左到右,上到下標儲存格索引
MsgBox Area.Item(1, 1).Address
MsgBox Area.Item(1, 5).Address
MsgBox Area.Item(1, 10).Address
MsgBox Area.Item(2, 1).Address
MsgBox Area.Item(10, 10).Address
MsgBox Area.Item(1, 11).Address
'↑範圍內的座標方式標儲存格索引
End Sub

作者: singo1232001 時間: 2022-12-7 22:36

回復 7# Andy2483

感覺好像有一招
準大還有其他大大常用的做法
字典嵌套或字典合併key值(列號+關鍵字)
可以縮短程序
若要取出列號再用replace把關鍵字移掉

作者: Andy2483 時間: 2022-12-8 07:19

本帖最後由 Andy2483 於 2022-12-8 07:28 編輯

回復 Andy2483

感覺好像有一招
準大還有其他大大常用的做法
字典嵌套或字典合併key值(列號+關鍵 ...
singo1232001 發表於 2022-12-7 22:36

謝謝前輩指點
後學(厚臉皮的學生)來研究一下!
可是前輩說的方式很魔法,可以再多提示一點嗎?
懇請前輩秀上您的方案嗎?
哪一帖有這種魔法招式?請前輩再提點一下!
拜託!

作者: samwang 時間: 2022-12-8 08:42

回復 1# Andy2483

您寫得很好了，參考您的修改一下，謝謝

Sub test()
Dim Arr, Brr, Crr, xD, xR, i&, j&, S&, N&, M&, R&, C&, D As Date
Set xD = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
.Replace What:=" ", Replacement:="", LookAt:=xlPart
.Sort Key1:=.Item(1), Order1:=1, Header:=1
Arr = .Value
Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
.Clear
End With
ReDim Crr(1 To UBound(Arr), 1 To 2)
For Each xR In Brr
If InStr(xR, "梯") Then
      S = InStr(xR, "梯") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      If Not xD.Exists(D) Then
         i = i + 1: xD(D) = i
         Crr(i, 1) = D: Crr(i, 2) = Trim(xR)
      End If
End If
Next
With Sheets("Sheet3").[a1].Resize(i, 2)
      .Value = Crr
      .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
      Brr = .Value
      .Clear
End With
xD.RemoveAll
ReDim Crr(1 To UBound(Arr), 1 To i)
For i = 1 To UBound(Brr)
M = M + 1: xD(Brr(i, 2)) = M
Crr(1, M) = Brr(i, 2)
Next
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
   If Arr(i, j) <> "" Then
      If Not xD.Exists(Arr(i, j) & "|" & Arr(i, 1)) Then
         R = xD(Arr(i, j) & "|R")
         If R = 0 Then R = R + 2 Else R = R + 1
         C = xD(Arr(i, j) & "")
         Crr(R, C) = Arr(i, 1)
         xD(Arr(i, j) & "|R") = R
         xD(Arr(i, j) & "|" & Arr(i, 1)) = ""
      End If
   End If
Next j
Next i
[Sheet3!A1].Resize(UBound(Crr), M) = Crr
Application.Goto [Sheet3!A1]
End Sub

作者: Andy2483 時間: 2022-12-8 16:01

回復 10# samwang

'謝謝前輩指導!後學獲益良多
'1.前輩的排除重複的情境是認為高O芬是接受報名的登錄者重複登錄該姓名,
'後學的排除重複的情境是認為高O芬是兩個不同名(以O模糊化中間字)的結果,或同名同姓,
'一件事不同看法正是後學執念想跳脫的,更能深思熟慮,對錯不是重點,是有趣的學習動力
'2.前輩的排除重複技巧後學收下了,待有機會應用這技巧
'3.這R = R + 2這段很厲害!後學學到了
'4.請再多多指教!謝謝
Option Explicit
Sub test_samwang()
Dim Arr, Brr, Crr, xD, xR, i&, j&, S&, N&, M&, R&, C&, D As Date
'↑宣告變數:
'(Arr, Brr, Crr, xD, xR):通用型
'(i&, j&, S&, N&, M&, R&, C&):長整數
'(D):日期
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD 是字典
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
'↑令"Sheet1" 工作表有使用的儲存格擴展為最小方正範圍儲存格複製到 [Sheet3!A1]開始的範圍
With Sheets("Sheet3").UsedRange
'↑以下是有關表三有使用的儲存格擴展為最小方正範圍儲存格的程序
.Replace What:=" ", Replacement:="", LookAt:=xlPart
'↑把" "空白字元置換為""空字元
.Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=xlTopToBottom
'↑.整個範圍排序:key基準是整個範圍的索引編號 1的儲存格所在的欄位
'Order1:=1排序方式是由小到大
'Header:=1有標題列,不參與排序
'縱向排序

'Orientation:=xlTopToBottom這縱向排序的陳述最好加上!
'不然EXCEL好像會儲存最後一次的排序方式:
'例如前次如果做Orientation:=xlLeftToRight,此次以為的縱向排序是做橫向排序
'學習這帖得到的以為EXCEL壞掉的可笑經驗
Arr = .Value
'↑令Arr是二維陣列!貼入排序後的整個範圍儲存格值
Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
'↑令Brr是二維陣列!貼入排序後的整個範圍的不含標題列也不含標題欄(姓名欄)儲存格值
.Clear
'令表三涵蓋有使用的儲存格最小方正區域儲存格清除
End With
ReDim Crr(1 To UBound(Arr), 1 To 2)
'宣告Crr二維陣列的範圍!縱向從1到 Arr陣列縱向最大列號數列,橫向從1到2欄
For Each xR In Brr
'↑設順迴圈!令xR是Brr的一個陣列值從左到右/下到上跑
If InStr(xR, "梯") Then
'↑如果xR的字串值裡有包含"梯"字元??
      S = InStr(xR, "梯") + 1
      '↑令S數字變數是 "梯"字元在xR字串裡字元位置數+1
      N = InStr(xR, "(")
      '↑令N數字變數是 "("字元在xR字串裡字元位置數
      D = Mid(xR, S, N - S)
      '↑令D是 xR字串裡從S位置開始,取N - S個字元的字串後,轉化為日期,
      '原來擷取的字串是沒有年分的日期字串,EXCEL會自動加上今年的年份,
      '如果日期是跨年分,排序就可能出問題了,使用者要注意!!
      '可以改用完整的年/月/日登錄做改善
      If Not xD.Exists(D) Then
      '↑如果以D日期變數查察xD字典結果是不存在這key??
         i = i + 1
         '↑令i數字變數累加1
         xD(D) = i
        '↑令以D日期變數為key,item是 i變數,放入xD字典裡
         Crr(i, 1) = D
          '↑令i迴圈列第1欄Crr陣列值是 D日期變數
         Crr(i, 2) = Trim(xR)
         '↑令i迴圈列第1欄Crr陣列值是 xR字串去除頭尾空白字元
         '這Trim()應該可以省略,被後學誤導了
      End If
End If
Next
With Sheets("Sheet3").[a1].Resize(i, 2)
'↑以下是關於表三[A1]儲存格開始擴展向下i列,向右擴展2欄的儲存格集
.Value = Crr
'↑令Crr陣列值倒入儲存格集裡
.Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
'↑.整個範圍排序:key基準是整個範圍的索引編號 1的儲存格所在的欄位
'Order1:=1排序方式是由小到大
'Header:=2 沒有標題列
'縱向排序
Brr = .Value
'令原Brr二維陣列初始化後,重新裝入排序後的儲存格集值
.Clear
'令表三儲存格集清除
End With
xD.RemoveAll
'↑清空xD字典
ReDim Crr(1 To UBound(Arr), 1 To i)
'↑令原Crr二維陣列初始化後,宣告Crr二維陣列的範圍!縱向從1到Arr陣列縱向最大列號數列,
'橫向從1到i變數欄
For i = 1 To UBound(Brr)
'↑設順迴圈!變數i從1到Brr陣列縱向最大列號數
M = M + 1
'↑M數字變數累加 1
xD(Brr(i, 2)) = M '@@1
'↑令以i迴圈列第2欄的Brr陣列值當key,item是 M數字變數!倒入xD字典裡
Crr(1, M) = Brr(i, 2)
'↑令第1列M數字變數欄Crr陣列值是 i迴圈列第2欄的Brr陣列值 PS:處裡結果表標題列
Next
For i = 2 To UBound(Arr)
'↑設外順迴圈!i變數從2到 Arr陣列縱向最大列號數
For j = 2 To UBound(Arr, 2)
'↑設外順迴圈!j變數從2到 Arr陣列橫向最大欄號數
   If Arr(i, j) <> "" Then
   '↑如果i迴圈列j迴圈欄的Arr陣列值不是空的
      If Not xD.Exists(Arr(i, j) & "|" & Arr(i, 1)) Then
      '↑再如果以梯次日期星期字串連接"|"符號,再連接姓名的組合字串,
      '查察xD字典結果是不存在這key ??
         R = xD(Arr(i, j) & "|R")
         '↑令R數字變數是以梯次日期星期字串連接"|R"字串的新字串,
         '查察xD字典得到的item值
         If R = 0 Then
         '↑如果R這數字變數是 0 ??
            R = R + 2
            '↑If條件成立!就令R數字變數累加 2  (放結果的列號)
            '因為每欄姓名是從第2列開始擺放!所以加 2
            Else
               R = R + 1
                '↑If條件不成立!就令R數字變數累加 1  (放結果的列號)
         End If
         C = xD(Arr(i, j) & "")
          '↑令C數字變數是梯次日期星期字串連接""的新字串,
          '查察xD字典得到的item值 (放結果的欄號,如上方 @@1標註位置)
         Crr(R, C) = Arr(i, 1)
          '↑令R變數列C變數欄的Crr陣列值是 i迴圈的姓名
         xD(Arr(i, j) & "|R") = R
          '↑令以梯次日期星期字串連接"|R"字串的字串為key,item是放結果的列號,
         '放入xD字典裡或置換該key對應的item值
         xD(Arr(i, j) & "|" & Arr(i, 1)) = ""
         '↑令以梯次日期星期字串連接"|"符號,再連接姓名的組合字串為key,
         'item是空字元,放入xD字典裡  排除重複報名
      End If
   End If
Next j
Next i
[Sheet3!A1].Resize(UBound(Crr), M) = Crr
'↑令表三[A1]擴展向下 Crr陣列縱向最大列號數列,向右擴展M欄的儲存格,倒入Crr陣列值
Application.Goto [Sheet3!A1]
End Sub

作者: Andy2483 時間: 2022-12-19 14:46

回復 8# singo1232001

謝謝前輩提示
後學試著把資料都放進字典裡,再倒出來並排除重複,是前輩所提示的方法嗎?
請前輩再指導,謝謝
執行過程:
[attach]35619[/attach]

結果:
[attach]35620[/attach]

程式碼如下:

Option Explicit
Sub TEST_直式梯次名單_20221219()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date, T$
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
.Replace What:=" ", Replacement:="", Lookat:=xlPart
.Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=xlTopToBottom
Arr = .Value
Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
.Clear
End With
For Each xR In Brr
If Trim(xR) <> "" Then
   S = InStr(xR, "梯") + 1
   N = InStr(xR, "(")
   D = Mid(xR, S, N - S)
   Y(D) = xR
End If
Next
[Sheet3!A2].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A1].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.ITEMS))
With Sheets("Sheet3").UsedRange
.Sort Key1:=.Item(2, 1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
Brr = .Resize(UBound(Arr))
End With
Y.RemoveAll
For i = 1 To UBound(Brr, 2)
Y(Brr(1, i)) = i
Next
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
   If Arr(i, j) <> "" Then
      Y(i & "|" & Arr(i, j)) = Arr(i, 1)
   End If
Next
Next
For Each xR In Y.KEYS
If InStr(xR, "|") Then
   T = Mid(xR, InStr(xR, "|") + 1)
   If Y(T & Y(xR)) = "" Then
      S = Y(T & "/a") + 1
      Brr(S + 1, Y(T)) = Y(xR)
      Y(T & "/a") = S
      Y(T & Y(xR)) = 1
   End If
End If
Next
[Sheet3!A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Brr = Nothing
Set Y = Nothing
End Sub

作者: Andy2483 時間: 2022-12-19 15:24

回復 8# singo1232001

還是以下這方法,在前方排除重複?

Option Explicit
Sub TEST_直式梯次名單_20221219_1()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date, T$
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
.Replace What:=" ", Replacement:="", Lookat:=xlPart
.Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=xlTopToBottom
Arr = .Value
Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
.Clear
End With
For Each xR In Brr
If Trim(xR) <> "" Then
   S = InStr(xR, "梯") + 1
   N = InStr(xR, "(")
   D = Mid(xR, S, N - S)
   Y(D) = xR
End If
Next
[Sheet3!A2].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A1].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.ITEMS))
With Sheets("Sheet3").UsedRange
.Sort Key1:=.Item(2, 1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
Brr = .Resize(UBound(Arr))
End With
Y.RemoveAll
For i = 1 To UBound(Brr, 2)
Y(Brr(1, i)) = i
Next
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
   If Arr(i, j) <> "" Then
      Y(Arr(i, 1) & "|" & Arr(i, j)) = ""
   End If
Next
Next
For Each xR In Y.KEYS
If InStr(xR, "|") And Y(xR) = "" Then
   T = Split(xR, "|")(1)
   S = Y(T & "/a") + 1
   Brr(S + 1, Y(T)) = Split(xR, "|")(0)
   Y(T & "/a") = S
   Y(xR) = 1
End If
Next
[Sheet3!A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Brr = Nothing
Set Y = Nothing
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)