Private Sub CommandButton1_Click()
Dim Arr, xD, s%, Tm, a%, i&, j&
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Application.ScreenUpdating = False '在背景下執行
For s = 1 To 6 '6個工作表
Shrr = Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8")
With Sheets(Shrr(s - 1))
Arr = .Range("d1:j" & .[b65536].End(3).Row)
For i = 2 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
If Arr(i, j) <> "" Then
If InStr(Arr(i, j), ",") Then
For w = 0 To UBound(Split(Arr(i, j), ","))
a = Split(Arr(i, j), ",")(w): xD(a) = ""
Next
Else
xD(Arr(i, j)) = ""
End If
End If
Next
Next
If xD.Count > 0 Then
For i = 1 To xD.Count: Arr(i, 1) = Application.Small(xD.keys, i): Next
With .Range("a4").Resize(xD.Count, 1)
.NumberFormatLocal = "00": .Value = Arr
End With
.[a2] = xD.Count & "個": Erase Arr: xD.RemoveAll
End If
End With
Next
MsgBox Timer - Tm
End Sub作者: ziv976688 時間: 2021-7-19 14:38
Private Sub CommandButton1_Click()
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Application.ScreenUpdating = False '在背景下執行
Shrr = Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8")
For s = 1 To 6 '6個工作表
With Sheets(Shrr(s - 1))
xRows = .[b65536].End(3).Row '資料最後一行位置
.range("A2:A" & xRows).ClearContents '清除資料
Arr = .range("D1:J" & xRows) '資料轉陣列，JOIN會快3倍 0.023 -> 0.0078
xJoin = ""
For Each x In Arr: xJoin = xJoin & IIf(x <> "", x & ",", ""): Next '合併D:J字串
For Each xS In Split(xJoin, ","): xD(xS) = "": Next '組字典
If xD.Count > 0 Then
.[A4].Resize(xD.Count, 1) = Application.Transpose(xD.keys) '字典取唯一、水平轉垂直、填入儲存格
.[A4].Resize(xD.Count, 1).Sort Key1:=.[A4], Order1:=xlAscending, Header:=xlNo '儲存格排序
.[A2] = xD.Count & "個": .[A3] = "號碼"
Erase Arr: xD.RemoveAll
End If
End With
Next
MsgBox Timer - Tm
End Sub作者: 准提部林 時間: 2021-7-19 19:02
Sub TEST()
Dim Brr(1 To 99, 0), xS As Worksheet, A, B
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))
For Each A In xS.Range("d2:j" & xS.[b65536].End(xlUp).Row + 1).Value
For Each B In Split(A, ",")
Brr(B, 0) = B
Next B
Next
With xS.[a4].Resize(99)
.Value = Brr: Erase Brr
.Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
End With
Next
End Sub作者: ziv976688 時間: 2021-7-20 12:23
15樓寫得很精簡
學習重寫如下
Private Sub CommandButton1_Click()
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Application.ScreenUpdating = False '在背景下執行
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8")) '取表格
For Each xR In xS.Range("D2:J" & xS.[B65536].End(xlUp).Row) '取儲存格
For Each sp In Split(xR, ",") '分開數字
If Val(sp) > 0 Then xD(Val(sp)) = s '字典組合
Next
Next
xS.[A4].Resize(99).ClearContents '清除儲存格內容
xS.[a2] = xD.Count & "個": xS.[A3] = "號碼"
If xD.Count = 0 Then Exit For
With xS.[A4].Resize(xD.Count)
.Value = Application.Transpose(xD.keys): xD.RemoveAll
.Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
End With
Next
End Sub作者: ziv976688 時間: 2021-7-20 15:23
回復 21#准提部林
Sub 餘數各取1()
Dim Brr(1 To 99, 0), xS As Worksheet, A, B
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))
For Each A In xS.Range("d2:j" & xS.[b65536].End(xlUp).Row + 1).Value
For Each B In Split(A, ",")
Brr(B, 0) = B
Next B
Next
With xS.[a4].Resize(99)
.Value = Brr: Erase Brr
.Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
End With
' With xS.[a2] = Application.Count(xS.[A4:A52]) & "個": End With
Next
End Sub
請問 :
列13是我寫錯程式碼，還是我放錯位列?
請您賜正。
謝謝您作者: ML089 時間: 2021-7-22 20:41
)。
!
