123456
返回列表 上一主題 發帖

[發問] 公式程式碼化

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2021-7-24 00:57 | 只看該作者

[發問] 公式程式碼化

本帖最後由 ziv976688 於 2021-7-24 01:07 編輯

不好意思，懇請各位大大指導和幫忙~
請將下列公式程式碼化。
謝謝！
公式程式碼化.rar (85.64 KB)
Sheets("準2進3")!D2的原公式
=LEFT(TEXT(SUM(TEXT(MOD(M2+(0&TRIM(MID(SUBSTITUTE(V2,",","         "),1+{0,1,2,3,4}*9,9))),49),"[=0]!49")*10^{8,6,4,2,0}),"00!,00!,00!,00!,00"),IF(V2="",0,2+3*(LEN(V2)-LEN(SUBSTITUTE(V2,",",)))))
右拉到J2，再下拉到.Range("J" & .[B2].End(xldown).row - 1) 填滿

Module 1
文字說明：
備註：
1_要相加的2個目標儲存格=M:S和V:AB二個區段之同列等欄距(間隔8欄)的各儲存格。
2_VB2:AB" & .[B2].End(xldown).row - 1) = ""的儲存格不計算(略過)。
3_餘數=0時，視同=49。   
4_有顯示2個(含)以上時，則以","符號區隔。
實例說明：
Sheets("準2進3")
當V2<>""時，則D2=(M2的值+V2的值)/49 =>取餘數
EX：D2 =MOD(11+8,49)=19
EX：D2 =MOD(11+27,49)=38
即D2=19,38
：
：
當AA2<>""時，則I2=(R2的值+AA2的值)/49 =>取餘數
EX：I2 =MOD(42+30,49)=23
即I2=23
：
：
當W13<>""時，則E13=(N13的值+W13的值)/49 =>取餘數
EX：E13 =MOD(04+0,49)=04
EX：E13 =MOD(04+45,49)=49
即E13=04,49
：
：
當AB26<>""時，則J26=(S26的值+AB26的值)/49 =>取餘數
EX：J26=MOD(02+9,49)=11
即J26= 11

其餘…Sheets("準3進4")~ Sheets("準7進8")…類推。
收藏 分享

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
2#
發表於 2021-7-24 22:58 | 只看該作者
本帖最後由 singo1232001 於 2021-7-24 23:12 編輯

回復 1# ziv976688
  1. Sub allsheet()   '<--執行這個
  2. Dim s As Worksheet
  3. For Each s In Worksheets
  4. If s.Name <> "DATA" Then Call 餘數登錄(s.Name)
  5. Next
  6. End Sub

  8. Sub 餘數登錄(sN)
  9. Set s = Sheets(sN)
  10. n = s.Columns("v:ab").Find("*", , -4163, , 1, 2).Row
  11. Dim ar
  12. ReDim ar(1 To n, 1 To 7)

  14. For i = 1 To n
  15. For j = 1 To 7
  16. x = s.Cells(i + 1, j + 21)
  17. If x <> "" Then
  18. x = Split(x, ",")
  19.     For Each x0 In x
  20.     x0 = (x0 + s.Cells(i + 1, j + 12)) Mod 49
  21.     If ar(i, j) <> "" Then ar(i, j) = ar(i, j) & "," & x0
  22.     If ar(i, j) = "" Then ar(i, j) = x0
  23.     Next
  24. End If
  25. Next
  26. Next
  27. s.[d2].Resize(n, 7) = ar
  28. End Sub
複製代碼

TOP

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2021-7-24 23:43 | 只看該作者
回復 2# singo1232001
  1. Sub allsheet()   '<--執行這個
  2. Dim s As Worksheet
  3. For Each s In Worksheets
  4. If s.Name <> "DATA" Then Call 餘數登錄(s.Name)
  5. Next
  6. End Sub

  8. Sub 餘數登錄(sN)
  9. Set s = Sheets(sN)
  10. n = s.Columns("v:ab").Find("*", , -4163, , 1, 2).Row
  11. Dim ar
  12. ReDim ar(1 To n, 1 To 7)

  14. For i = 1 To n
  15. For j = 1 To 7
  16. x = s.Cells(i + 1, j + 21)
  17. If x <> "" Then
  18. x = Split(x, ",")
  19.     For Each x0 In x
  20.     x0 = Format((x0 + s.Cells(i + 1, j + 12)) Mod 49,"00") <--忘了加00
  21.     If ar(i, j) <> "" Then ar(i, j) = ar(i, j) & "," & x0
  22.     If ar(i, j) = "" Then ar(i, j) = x0
  23.     Next
  24. End If
  25. Next
  26. Next
  27. s.[d2].Resize(n, 7) = ar
  28. End Sub
複製代碼

TOP

ML089

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

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

ziv976688

帖子
678 
主題
147 
精華
0 
積分
799 
點名
0  
作業系統
win 8 
軟體版本
MS 2003 
閱讀權限
50 
性別
男 
註冊時間
2016-2-9 
最後登錄
2022-1-20 
5#
發表於 2021-7-25 09:04 | 只看該作者
回復  singo1232001
singo1232001 發表於 2021-7-24 23:43

公式程式碼化_singo1232001.rar (85.97 KB)
測試結果 :答案都是 FALSE
請再修正~謝謝您

TOP

ziv976688

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

回復 4# ML089
測試成功
程式碼加註解~受益良多
謝謝版主的耐心指導漢一再的熱心幫忙~感恩

TOP

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
7#
發表於 2021-7-25 14:47 | 只看該作者
回復 6# ziv976688

公式程式碼化_singo1232001.zip (117.49 KB)

TOP

ziv976688

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

回復 7# singo1232001
公式程式碼化_singo1232001_V1.rar (99.52 KB) =>可按清除鍵測試
99%OK了!
只差列20
x0 = Format((x0 + s.Cells(i + 1, j + 12)) Mod 49, "00") '< --忘了加00
請再加上如下條件需求 :
當餘數=0時，視同=49
EX: E10=19,00
正確應為~
E10=19,49
謝謝您

TOP

ziv976688

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

回復 4# ML089
標示底色.rar (105.15 KB) =>可按清除鍵測試
不好意思，可否請版主賜正~
標示底色
Module 5
' If xR > 0 And xR = xS.Range("M" & xS.[B65536].End(xlUp).Row, "S" & xS.[B65536].End(xlUp).Row) Then xR.Interior.ColorIndex = 8  '標示藍底色
列7
=當A4:A52<>""的某儲存格之值~
有顯示在M:S有數字之最後一列的任一個儲存格時，
則A欄的該值之儲存格標示藍底色。

' 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 '標示藍底色
列12
=當xS.Range("D2:J" & xS.[B65536].End(xlUp).Row - 1) <>""的某儲存格之任1個值~
有顯示在M:S最後一列的任一個儲存格時，
則xS.Range("D2:J" & xS.[B65536].End(xlUp).Row - 1)的該值之儲存格標示藍底色。

請問：
Module 5的列7和列12之程式碼要如何修正 ?
謝謝您

TOP

ML089

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

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

        靜思自在 : 虛空有盡．我願無窮，發願容易行願難。
123456
返回列表 上一主題