123456
返回列表 上一主題 發帖

[發問] 公式程式碼化

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
38# 跳轉到 »
發表於 2021-7-27 16:35 | 只看該作者
回復 37# ML089
xS.[A2] = IIf(N = 0, "", N & "個")
程式碼沒有錯~
為什麼"準6進7"和 "準7進8"的A2不一致 ?
進7的A2=0個；進8的A2="" =>不是A2都=""
請賜教!謝謝您

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
37#
發表於 2021-7-27 11:24 | 只看該作者
回復 35# ziv976688
我想您的"標示底色"之程式碼應該是正解~
因為我發現Bug出在列12 xS.[a2] = xD.Count & "個"，
它會讓"準6進7"的A2顯示0個，但"準7進8"的A2卻顯示""，且標示藍底色；
如果我在列20插入 xS.[a2] = Application.Count(xS.[A4:A52]) & "個" 測試~
"準7進8"的A2之藍色標示就會消失。但還是顯示""(不是顯示0個)~
可見插入列20也不是完全生效(正確)~是什麼因?我也不懂。
因為程式的流程關係，我既不能移除列12，也不知道怎麼修正?

餘數各取1 有點BUG，xD.count=0時不應該EXIT FOR，導致後面表格沒有處理
Sub 餘數各取1()
    Dim xD As Object, xS As Worksheet, xR As Range, SP, N
    Tm = Timer
    Set xD = CreateObject("Scripting.Dictionary")
    For Each xS In Sheets(Split("準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)) = ""    '字典組合
            Next
        Next
        N = xD.Count
        xS.[A2:A110].ClearContents    '清除儲存格內容
        xS.[A2] = IIf(N = 0, "", N & "個")
        xS.[A3] = "號碼"
        
        If N > 1 Then    'xD.Count > 1時，才需要排序，不然會錯
            With xS.[A4].Resize(N)
                .Value = Application.Transpose(xD.keys)
                .Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
            End With
        End If
        xD.RemoveAll
    Next
    Debug.Print Format(Timer - Tm, "0.00秒") & " 餘數各取1"
End Sub

格式化部分能需要在微調
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
36#
發表於 2021-7-27 10:34 | 只看該作者
回復 26# ziv976688

修改DATA裡的 主程式，將資料複製與格式化作業分離，
原先資料複製已經是完整作業程序，放在格式化作業內在每個表格又重複做6次
檔案參考如下

    標示底色_ML089_C1_DATA_VBA修改.zip (149.68 KB)
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
35#
發表於 2021-7-27 05:57 | 只看該作者
本帖最後由 ziv976688 於 2021-7-27 06:18 編輯

回復 33# ML089
版主 :
我想您的"標示底色"之程式碼應該是正解~
因為我發現Bug出在列12 xS.[a2] = xD.Count & "個"，
它會讓"準6進7"的A2顯示0個，但"準7進8"的A2卻顯示""，且標示藍底色；
如果我在列20插入 xS.[a2] = Application.Count(xS.[A4:A52]) & "個" 測試~
"準7進8"的A2之藍色標示就會消失。但還是顯示""(不是顯示0個)~
可見插入列20也不是完全生效(正確)~是什麼因?我也不懂。
因為程式的流程關係，我既不能移除列12，也不知道怎麼修正?
所以又上來請教
以上只是我個人的一點想法，僅供您參考~BUG的猜測對或不對，我沒有信心^^"

真不好意思，因為想研習貴語法，一再給您添麻煩~尚請您見諒
VBA還真不易學，只是一個數值個數統計的小問題~就考倒我了

TOP

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
34#
發表於 2021-7-26 23:09 | 只看該作者
回復 33# ML089
版主 :
餘數各取1測試成功
謝謝您耐心指導~感恩
您的加註~讓我受益良多

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
33#
發表於 2021-7-26 20:57 | 只看該作者
回復 29# ziv976688

先回覆問題 2
排序錯誤修正，xD.Count = 1時，排序範圍變成整個表格造成錯誤

Sub 餘數各取1()
Dim xD As Object, xS As Worksheet, xR As Range, SP
   
    Set xD = CreateObject("Scripting.Dictionary")
    For Each xS In Sheets(Split("準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)) = "" '字典組合
            Next
        Next
        xS.[A2:A110].ClearContents '清除儲存格內容
        xS.[a2] = xD.Count & "個": xS.[A3] = "號碼"
        N = xD.Count: If N = 0 Then Exit For
        With xS.[A4].Resize(N)
            .Value = Application.Transpose(xD.keys)
            '排序錯誤修正，xD.Count = 1時，排序範圍變成整個表格造成錯誤
            If N > 1 Then .Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
            xD.RemoveAll
        End With
    Next
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
32#
發表於 2021-7-26 15:17 | 只看該作者
回復 31# 准提部林
版主 :
我本來是想研習各位大大的語法，所以針對各人的語法，我有不瞭解的地方頻頻發問~給大家添麻煩了~抱歉!

感謝您將這二段程式補齊。
您太厲害了~全檔執行時間不到2秒

萬分感謝您的指導和幫忙

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-10-18 
31#
發表於 2021-7-26 14:47 | 只看該作者
Sub 標示底色()
Dim xS As Worksheet, R&, Arr, A, xD, xU As Range, N&
Set xD = CreateObject("Scripting.Dictionary")
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))
    R = xS.[b65536].End(xlUp).Row
    xS.[d2].Resize(R, 7).Interior.ColorIndex = xlNone
    Set xU = xS.[c2]
    For j = 1 To 7:   xD(Val(xS.Cells(R, j + 12))) = 1: Next j
    Arr = xS.[d1].Resize(R, 7)
    For i = 2 To R:  For j = 1 To 7
        For Each A In Split(Arr(i, j), ",")
            If xD(Val(A)) > 0 Then Set xU = Union(xS.Cells(i, j + 3), xU): Exit For
        Next A
    Next j: Next i
    '-------------------------------
    R = xS.[a65536].End(xlUp).Row
    xS.[a4].Resize(R).Interior.ColorIndex = xlNone
    Arr = xS.[a1].Resize(R)
    For i = 4 To R
        If xD(Val(Arr(i, 1))) > 0 Then Set xU = Union(xS.Cells(i, 1), xU)
    Next i
    xU.Interior.ColorIndex = 8
    xS.[c2].Interior.ColorIndex = xlNone
    xD.RemoveAll: N = 0
Next xS
End Sub

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-10-18 
30#
發表於 2021-7-26 14:47 | 只看該作者
Sub 餘數登錄()
Dim xS As Worksheet, R&, Arr, Brr, A
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))
    R = xS.[b65536].End(xlUp).Row - 1
    Arr = xS.[m2:ab2].Resize(R)
    ReDim Brr(1 To R, 1 To 7)
    For i = 1 To R
    For j = 1 To 7
        For Each A In Split(Arr(i, j + 9), ",")
            Brr(i, j) = Brr(i, j) & "," & Format((Arr(i, j) + Val(A)) Mod 49, "00;;49")
        Next A
        Brr(i, j) = Mid(Brr(i, j), 2)
    Next j
    Next i
    xS.[d2].Resize(R, 7) = Brr
Next xS
End Sub

TOP

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
29#
發表於 2021-7-26 14:24 | 只看該作者
本帖最後由 ziv976688 於 2021-7-26 14:26 編輯

回復 27# ML089
標示底色_ML089_C1.rar (107.42 KB)
花了半天~將您所賜教的解答檔，全部檢測完畢~
報告如下：
1_您的個別解答檔 => 全部OK

2_以最後完成的檔案(標示底色_ML089_C1)測試~
Call 參數登錄和Call 餘數登錄 => 執行，
'Call 餘數各取1 => 不執行 => 產生A2=""時，也會標示藍底色(只有"準2進3"正常)

3_以最後完成的檔案(標示底色_ML089_C1)測試~
Call 參數登錄和Call 餘數登錄和Call 餘數各取1 => 全部執行，
"準5進6"的標題列會移到第4列 =>請先將DATA!VB的列59，改為執行狀態，
然後按執行鍵~測試結果。
如果要重新測試~請按清除鍵即可。

4_執行模組程式碼應放置在DATA!VB~
For s = 1 To 6   '6個工作表
：
NEXT
            Call 參數登錄
            Call 餘數登錄
            Call 餘數各取1
            Call 標示底色
我還想不出怎麼解決版面設定失效的問題

以上   懇請您賜教是幸！  謝謝您

TOP

        靜思自在 : 能善用時間的人，必能掌握自己努力的方向。
123456
返回列表 上一主題