- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-3-24
|
回復 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 |
|
發表於 2022-12-8 16:01
| 
