ziv976688

回復 5# ML089
不好意思，我將公式套用在VBA語法中~產生偵錯。
只是FREQUENCY和TRIM和SUBSTITUTE等函數對我來說~太深奧了~
恐怕是我將原5欄39個號碼的貴解，套用在7欄49個號碼公式時有改錯了!？
煩請您幫我檢視一下~ 好嗎 ?
或者請您直接以程式語法解題(有看過您解過程式題 )。
謝謝您
數字各取1(儲存格有,區隔符號)_VBA.rar (96.34 KB)

下載次數: 5

2021-7-19 06:50

下載 (36.1 KB)

2021-7-19 06:52

下載 (12.29 KB)

2021-7-19 06:53

samwang

回復 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

ziv976688

回復 12# samwang
測試成功 !
執行效率優化許多~只可惜，我一直搞不懂Arr和Brr要怎麼設立範圍和運算?
所以遇到多個Sheet(s)的範圍要運算就一籌莫展
感謝您一再的幫忙~感恩

ML089

回復 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

准提部林

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

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

ziv976688

回復 15# 准提部林
測試成功
感謝版主的指導

ziv976688

回復 14# ML089
不好意思，沒有注意到測試附件未上傳
數字各取1_ML089.rar (89.83 KB)

下載次數: 2

2021-7-20 13:16

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

ziv976688

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

ML089

回復 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