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

ML089

版主 Rank: 7 Rank: 7 Rank: 7

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

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

1^# 跳轉到 »

發表於 2021-7-9 14:59 | 顯示全部帖子

數字不超過2位數整數嗎?

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

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

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

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

2^#

發表於 2021-7-10 11:48 | 顯示全部帖子

回復 1# ziv976688

A2 陣列公式，如下
=LOOKUP(99,IF({1;0},{0,""},{1,1}*SMALL((FREQUENCY(--(0&TRIM(MID(SUBSTITUTE(B$2:B$33&","&C$2:C$33&","&D$2:D$33&","&E$2:E$33&","&F$2:F$33&",,,,,",","," "),{0,1,2,3,4}*9+1,9))),ROW($1:$99)-1)=0)*999+(ROW($1:$100)-1),ROW(A2))))
以三鍵方式輸入公式(SHIT+CTRL+ENTER)

公式限制
數字1~99
B:F每一列合併之數字串數也不能太多(3~5個)，因為字串分隔只插入9個空格，也可增加插入空格來提高字串數。

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

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

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

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

3^#

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

ML089

版主 Rank: 7 Rank: 7 Rank: 7

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

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

4^#

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

ML089

版主 Rank: 7 Rank: 7 Rank: 7

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

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

5^#

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

ML089

版主 Rank: 7 Rank: 7 Rank: 7

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

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

6^#

發表於 2021-7-22 20:41 | 顯示全部帖子

回復 27# ziv976688

1_列6的sp是什麼涵義? special?
需不需要設立變數?
2_我現在設立的變數對不對?夠不夠全?

SP是一個變數，名稱為隨意定，當初是以 Split 簡寫
好的程式應該是要定義變數比較嚴謹，因為VBA不強迫宣告變數，加上我是業餘寫小程式就沒習慣定義變數。

這小程式有4個變數可以定義如下
Dim xD As Object, xS As Worksheet, xR As Range, SP

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

TOP

[發問] 數字各取1

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]