12
返回列表 上一主題 發帖

[發問] 公式程式碼化

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
1# 跳轉到 »
發表於 2021-7-25 05:22 | 顯示全部帖子
回復 1# ziv976688
Sub 餘數登錄()
    Dim xS As Worksheet, xV As Range, xD, SP
    Tm = Timer
    For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))    '取表格
        For Each xV In xS.Range("V2:AB" & xS.[B65536].End(xlUp).Row)    '取儲存格
            xD = ""
            For Each SP In Split(xV, ",")    '分離字串
                SP = (SP + xV.Offset(, -9)) Mod 49: If SP = 0 Then SP = 49 'V2+M2 mod 49
                xD = xD & "," & Format(SP, "00")
            Next
            xV.Offset(30, -18) = Mid(xD, 2, 99) '測試用 位置下移30格
            'xV.Offset(, -18) = Mid(xD, 2, 99) '正確位置
        Next
    Next
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
2#
發表於 2021-7-25 17:23 | 顯示全部帖子
本帖最後由 ML089 於 2021-7-25 17:25 編輯

回復 9# ziv976688

Sub 標示底色()
    Dim  xS As Worksheet, xR As Range, SP, r
   
    For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))    '取表格
        r = xS.[B65536].End(xlUp).Row
        For Each xR In xS.Range("A4:A" & xS.[A65536].End(xlUp).Row)    '取儲存格
            'xR.Interior.ColorIndex = 0 '清底色
            If Not xS.Range("M2:S" & r).Find(xR) Is Nothing Then xR.Interior.ColorIndex = 8  '標示藍底色
        Next

        For Each xR In xS.Range("D2:J" & r - 1)    '取儲存格
            'xR.Interior.ColorIndex = 0 '清底色
            For Each SP In Split(xR, ",")    '分開數字
                If Not xS.Range("M2:S" & r).Find(Val(SP)) Is Nothing Then xR.Interior.ColorIndex = 8: Exit For    '標示藍底色
            Next
        Next
    Next
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
3#
發表於 2021-7-25 18:46 | 顯示全部帖子
回復 11# ziv976688
是最後一列資料，我看錯了，修正如下
Sub 標示底色_ML089()
    Dim xD As Object, xS As Worksheet, xR As Range, SP, r
    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
        For Each xR In xS.Range("A4:A" & xS.[A65536].End(xlUp).Row)    '取儲存格
            xR.Interior.ColorIndex = 0 '清底色
            'If xR > 0 And xR = xS.Range("M" & xS.[B65536].End(xlUp).Row, "S" & xS.[B65536].End(xlUp).Row) Then xR.Interior.ColorIndex = 8  '標示藍底色
            If Not xS.Range("M" & r, "S" & r).Find(xR, LookAt:=xlWhole) Is Nothing Then xR.Interior.ColorIndex = 8  '標示藍底色
        Next

        For Each xR In xS.Range("D2:J" & r - 1)    '取儲存格
            xR.Interior.ColorIndex = 0 '清底色
            For Each SP In Split(xR, ",")    '分開數字
                'If Val(SP) > 0 And Val(SP) = xS.Range("M" & xS.[B65536].End(xlUp).Row, "S" & xS.[B65536].End(xlUp).Row) Then xD(Val(SP)).Interior.ColorIndex = 8 '標示藍底色
                If Not xS.Range("M" & r, "S" & r).Find(Val(SP), LookAt:=xlWhole) Is Nothing Then xR.Interior.ColorIndex = 8: Exit For     '標示藍底色
            Next
        Next
    Next
End Sub
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
4#
發表於 2021-7-25 23:11 | 顯示全部帖子
回復 17# ziv976688

我執行是還好4.5秒完成，當然改為陣列

準7進8 的 V2:AB2 資料有誤，你修改後在執行看看
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
5#
發表於 2021-7-25 23:37 | 顯示全部帖子
回復 17# ziv976688

問題1：DATA!VB 下列放置位置應該在 迴圈之外
    For s = 1 To 6   '6個工作表
        Shrr = Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8")
.
.
    NEXT
            'Call 參數登錄
            Call 餘數登錄
            Call 餘數各取1
            Call 標示底色

    問題2： "準7進8" 做出來的資料有誤，你再查看看
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
6#
發表於 2021-7-26 09:04 | 顯示全部帖子
回復 26# ziv976688

版面的設定，應該是放到最後面，順序如下

資料
計算
排版
列印
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
7#
發表於 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

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
8#
發表於 2021-7-27 10:34 | 顯示全部帖子
回復 26# ziv976688

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

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

TOP

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
9#
發表於 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猴年全勤獎章
10#
發表於 2021-7-27 17:47 | 顯示全部帖子
回復  ML089
xS.[A2] = IIf(N = 0, "", N & "個")
程式碼沒有錯~
為什麼"準6進7"和 "準7進8"的A2不一致 ...
ziv976688 發表於 2021-7-27 16:35



  之前程式錯誤是 因為後面有此程序 EXIT FOR，
當 "準6進7" [A2] = "" : EXIT FOR 就跳離FOR 迴圈，"準7進8"沒有被執行到所以是 空格(一般視為0)
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

        靜思自在 : 稻穗結得越飽滿，越會往下垂，一個人越有成就，就要越有謙沖的胸襟。
12
返回列表 上一主題