數字各取1 - Excelㄧ般區 - 麻辣家族討論版版

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

12^#

發表於 2021-7-19 13:49 | 只看該作者

回復 11# ziv976688

請測試看看，謝謝

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

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

13^#

發表於 2021-7-19 14:38 | 只看該作者

回復 12# samwang
測試成功

!
執行效率優化許多~只可惜，我一直搞不懂Arr和Brr要怎麼設立範圍和運算?
所以遇到多個Sheet(s)的範圍要運算就一籌莫展

感謝您一再的幫忙~感恩

版主 Rank: 7 Rank: 7 Rank: 7

ML089

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

14^#

發表於 2021-7-19 18:35 | 只看該作者

回復 11# ziv976688

不是很會寫VBA，湊一個給你參考

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

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

15^#

發表於 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

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

16^#

發表於 2021-7-20 12:23 | 只看該作者

本帖最後由 ziv976688 於 2021-7-20 12:41 編輯

回復 14# ML089
少了取1~~
有附上註明~幫助我能比較明瞭。
感謝版主的指導

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

17^#

發表於 2021-7-20 12:26 | 只看該作者

回復 15# 准提部林
測試成功

感謝版主的指導

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

18^#

發表於 2021-7-20 13:17 | 只看該作者

本帖最後由 ziv976688 於 2021-7-20 13:21 編輯

回復 14# ML089
不好意思，沒有注意到測試附件未上傳

數字各取1_ML089.rar (89.83 KB)

有看到列17
.[A4].Resize(xD.Count, 1) = Application.Transpose(xD.keys) '字典取唯一、水平轉垂直、填入儲存格
可是不知道怎麼修正

謝謝您

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

19^#

發表於 2021-7-20 13:58 | 只看該作者

本帖最後由 ziv976688 於 2021-7-20 14:04 編輯

回復 15# 准提部林
不好意思，雖然能以別的方法解決，但很想研習您的語法~
請問 :
A2=COUNT(A4:A52)&"個" '只要統計49格，因為最多也只有49個號碼
以您的語法，應該怎麼編寫 ?
謝謝您

版主 Rank: 7 Rank: 7 Rank: 7

ML089

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

20^#

發表於 2021-7-20 15:05 | 只看該作者

回復 18# ziv976688

修正程式 02 與 2 會重複
Private Sub CommandButton1_Click()
Dim s%, Tm
Tm = Timer
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("D2: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, ",")
            If Val(xS) > 0 Then xD(Val(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
'    Sheets(Shrr).Copy
' ActiveWorkbook.SaveAs ThisWorkbook.Path & "\TEST_" & Nrange & "-" & Num & "期" & ".xls"
' ActiveWindow.Close
'MsgBox Timer - Tm
End Sub

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式