1234
返回列表 上一主題 發帖

[發問] 數字各取1

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
23# 跳轉到 »
發表於 2021-7-20 15:23 | 只看該作者
測試OK了!
感謝您的耐心指導

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
22#
發表於 2021-7-20 15:15 | 只看該作者
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
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

准提部林

帖子
2808 
主題
10 
精華
0 
積分
2864 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-10 
21#
發表於 2021-7-20 15:12 | 只看該作者
回復 19# ziv976688


with [A2]: .formula="=COUNT(A4:A52)&""個""" : .value=.value: end with

或 A2=application.COUNT(xS.[A4:A52]) & "個"

TOP

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 三鍵輸入公式

TOP

ziv976688

帖子
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個號碼
以您的語法，應該怎麼編寫 ?
謝謝您

TOP

ziv976688

帖子
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)    '字典取唯一、水平轉垂直、填入儲存格
可是不知道怎麼修正
謝謝您

TOP

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
17#
發表於 2021-7-20 12:26 | 只看該作者
回復 15# 准提部林
測試成功
感謝版主的指導

TOP

ziv976688

帖子
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~~
有附上註明~幫助我能比較明瞭。
感謝版主的指導

TOP

准提部林

帖子
2808 
主題
10 
精華
0 
積分
2864 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-10 
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

TOP

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 三鍵輸入公式

TOP

        靜思自在 : 犯錯出懺悔心，才能清淨無煩惱。
1234
返回列表 上一主題