返回列表 上一主題 發帖

[發問] 公式程式碼化

[發問] 公式程式碼化

本帖最後由 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 於 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

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

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

TOP

回復 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

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

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

TOP

回復 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

回復  singo1232001
singo1232001 發表於 2021-7-24 23:43

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

TOP

本帖最後由 ziv976688 於 2021-7-25 09:08 編輯

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

TOP

回復 6# ziv976688

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

TOP

本帖最後由 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 於 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 於 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

        靜思自在 : 口說好話、心想好意、身行好事。
返回列表 上一主題