麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 公式程式碼化 [打印本頁]

作者: ziv976688 時間: 2021-7-24 00:57 標題: 公式程式碼化

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

不好意思，懇請各位大大指導和幫忙~
請將下列公式程式碼化。
謝謝！
[attach]33735[/attach]
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 22:58

本帖最後由 singo1232001 於 2021-7-24 23:12 編輯

回復 1# ziv976688

Sub allsheet() '<--執行這個
Dim s As Worksheet
For Each s In Worksheets
If s.Name <> "DATA" Then Call 餘數登錄(s.Name)
Next
End Sub
Sub 餘數登錄(sN)
Set s = Sheets(sN)
n = s.Columns("v:ab").Find("*", , -4163, , 1, 2).Row
Dim ar
ReDim ar(1 To n, 1 To 7)
For i = 1 To n
For j = 1 To 7
x = s.Cells(i + 1, j + 21)
If x <> "" Then
x = Split(x, ",")
For Each x0 In x
x0 = (x0 + s.Cells(i + 1, j + 12)) Mod 49
If ar(i, j) <> "" Then ar(i, j) = ar(i, j) & "," & x0
If ar(i, j) = "" Then ar(i, j) = x0
Next
End If
Next
Next
s.[d2].Resize(n, 7) = ar
End Sub

複製代碼

作者: singo1232001 時間: 2021-7-24 23:43

回復 2# singo1232001

Sub allsheet() '<--執行這個
Dim s As Worksheet
For Each s In Worksheets
If s.Name <> "DATA" Then Call 餘數登錄(s.Name)
Next
End Sub
Sub 餘數登錄(sN)
Set s = Sheets(sN)
n = s.Columns("v:ab").Find("*", , -4163, , 1, 2).Row
Dim ar
ReDim ar(1 To n, 1 To 7)
For i = 1 To n
For j = 1 To 7
x = s.Cells(i + 1, j + 21)
If x <> "" Then
x = Split(x, ",")
For Each x0 In x
x0 = Format((x0 + s.Cells(i + 1, j + 12)) Mod 49,"00") <--忘了加00
If ar(i, j) <> "" Then ar(i, j) = ar(i, j) & "," & x0
If ar(i, j) = "" Then ar(i, j) = x0
Next
End If
Next
Next
s.[d2].Resize(n, 7) = ar
End Sub

複製代碼

作者: ML089 時間: 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

作者: ziv976688 時間: 2021-7-25 09:04

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

[attach]33742[/attach]
測試結果 :答案都是 FALSE
請再修正~謝謝您

作者: ziv976688 時間: 2021-7-25 09:07

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

回復 4# ML089
測試成功

程式碼加註解~受益良多

謝謝版主的耐心指導漢一再的熱心幫忙~感恩

作者: singo1232001 時間: 2021-7-25 14:47

回復 6# ziv976688

作者: ziv976688 時間: 2021-7-25 16:03

本帖最後由 ziv976688 於 2021-7-25 16:27 編輯

回復 7# singo1232001
[attach]33745[/attach] =>可按清除鍵測試
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
謝謝您

作者: ziv976688 時間: 2021-7-25 16:11

本帖最後由 ziv976688 於 2021-7-25 16:27 編輯

回復 4# ML089
[attach]33746[/attach] =>可按清除鍵測試
不好意思，可否請版主賜正~
標示底色
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之程式碼要如何修正 ?
謝謝您

作者: ML089 時間: 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

作者: ziv976688 時間: 2021-7-25 17:41

回復 10# ML089
[attach]33747[/attach] =>可按清除鍵測試
版主 :
您是不是誤解需求的意思了

If Not....Is Nothing.....
變成<>""的儲存格全部標示藍色
請賜正!謝謝您

作者: n7822123 時間: 2021-7-25 17:53

回復 11# ziv976688

用Match 做法寫給你

Sub 標示底色_Ex()
Dim Arr, Shs$, Num, Sh As Worksheet, Rg As Range
Shs = "準2進3 準3進4 準4進5 準5進6 準6進7 準7進8"
For Each Sh In Sheets(Split(Shs)): With Sh
  Arr = .[M2].End(4).Resize(, 7)
  Arr = Application.Transpose(Application.Transpose(Arr))  '轉一維
  For Each Rg In Union(.Range("A4:A52"), .Range("D2:J" & .[B65536].End(xlUp).Row - 1))
Rg.Interior.ColorIndex = 0                         '清底色
For Each Num In Split(Rg, ",")
   K = Application.Match(--Num, Arr, 0)                   '-- 轉數字比對
   If Not IsError(K) Then Rg.Interior.ColorIndex = 8  '標示藍底色
Next Num
  Next Rg
End With: Next Sh
End Sub

作者: n7822123 時間: 2021-7-25 17:58

本帖最後由 n7822123 於 2021-7-25 18:00 編輯

回復 1# ziv976688

針對1樓需求~~版主已完成，再錦上添花一下~~

看你的序號從 1853~1878，若數列多

用陣列運算，速度應該會快一些

純數值才可以這樣做，改變儲存格顏色啥的，用儲存格就好~

Sub 餘數()
Dim Arr(1 To 2), Brr, Sh As Worksheet, Shs$
Shs = "準2進3 準3進4 準4進5 準5進6 準6進7 準7進8"
For Each Sh In Sheets(Split(Shs)): With Sh
  Rn& = .[B2].End(4).Row - 1: ReDim Brr(1 To Rn, 1 To 7)
  Arr(1) = .[M2].Resize(Rn, 7): Arr(2) = .[V2].Resize(Rn, 7)
  For R = 1 To Rn: For C = 1 To 7
For Each Num In Split(Arr(2)(R, C), ",")
   餘數 = (Arr(1)(R, C) + Num - 1) Mod 49 + 1
   Brr(R, C) = Brr(R, C) & "," & Format(餘數, "00")
Next Num
Brr(R, C) = Mid(Brr(R, C), 2)
  Next C: Next R
  .[D30].Resize(Rn, 7) = Brr '測試用
  '.[D2].Resize(Rn, 7) = Brr    '正確位置
End With: Next Sh
End Sub

作者: ML089 時間: 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

作者: ziv976688 時間: 2021-7-25 19:37

回復 12# n7822123
測試成功

謝謝您的幫忙和指導~感恩

作者: ziv976688 時間: 2021-7-25 19:45

本帖最後由 ziv976688 於 2021-7-25 19:51 編輯

回復 13# n7822123
測試成功

謝謝您的幫忙和指導~感恩

不好意思，請教一下 :
  列8
  For Each Num In Split(Arr(2)(R, C), ",")
   餘數 = (Arr(1)(R, C) + Num - 1) Mod 49 + 1
請問 :
Num是指填入控制箱的期距數  Num = "25" 嗎?
還是只是變數 ?
謝謝您

作者: ziv976688 時間: 2021-7-25 20:04

本帖最後由 ziv976688 於 2021-7-25 20:07 編輯

回復 14# ML089
測試成功

謝謝您的幫忙和指導~感恩

請教一下 :
Module 3 餘數登錄
執行起來會卡卡的~游標一值跳
如果把DATA!VB編輯器的列47 Call 餘數登錄點為註解~
游標就正常不跳了。
請問 :
這是什麼原因 ?
是不是我的電腦有問題 ?
[attach]33748[/attach]
謝謝您

作者: singo1232001 時間: 2021-7-25 20:21

本帖最後由 singo1232001 於 2021-7-25 20:29 編輯

回復 17# ziv976688

作者: ziv976688 時間: 2021-7-25 20:31

回復 18# singo1232001
測試成功

謝謝您的幫忙和指導~感恩

作者: singo1232001 時間: 2021-7-25 21:22

本帖最後由 singo1232001 於 2021-7-25 21:34 編輯

回復 n7822123
測試成功
謝謝您的幫忙和指導~感恩

不好意思，請教一下 :
列 ...
ziv976688 發表於 2021-7-25 19:45

不好意思，請教一下 :
  列8
  For Each Num In Split(Arr(2)(R, C), ",")
   餘數 = (Arr(1)(R, C) + Num - 1) Mod 49 + 1
請問 :
Num是指填入控制箱的期距數  Num = "25" 嗎?
還是只是變數 ?
謝謝您
'------------------------------------------
幫忙解讀一下
這段是縮寫
需要先拆分
並且先從split的基礎運用方式先學
x=Split(Arr(2)(R, C), ",")
要先了解這段的意思
就必須先了解
Arr(2)(R, C)
又是甚麼意思
Arr(1) 跟arr(2)
你就想像成兩個虛擬的工作表 (實際名稱 "陣列")
所以
Arr(2)(R,C)
就代表在第二張虛擬工作表的某個儲存格因為有R列C欄值
因為在陣列中處理速度比較快也比較單純
依照準2進3工作表[V2]匯入當前Arr(2)虛擬工作表的位置
最終就能取得一組字串比如 "8,27"
位置應該是Arr(2)陣列的(0,0)

那麼我們回到
x=Split(Arr(2)(R, C), ",")
意思就是
x=Split("8,27", ",")
這是一種你給他分隔值她就幫你依照分隔值切分的函數並且會個別存放
如上的意思
我將8,27 依照","符號切分
最後我會得到
8 與27兩個值
分別放在
x(0)  <-裡面是8
x(1)  <-裡面是27
的裏面
如果你給他的字串是5,4,3,2
那麼你就會得到
x(0) <-裡面是5
x(1) <-裡面是4
x(2) <-裡面是3
x(3) <-裡面是2

如上述如果想要取得x(1)資料
我們就可以
y=x(1)
那麼y的值就是4

接著講
迴圈分兩種
for i = 1 to 4  這代表這回圈是 1 2 3 4
另一種是
for each a In x
這概念不同的地方很簡單

假設現在面前有40個大頭兵他們是A班
第一種就是你說1號他出來1號
而且你必須確認裡面有多少人才不會漏報或者多報
第二種則是你說 A班報數
這種方式就不用知道這班有多少人存在
也就是就從當前的順位第一個到最後一個一個一個自己站出來

這樣我們就能了解第一段
  For Each Num In Split("8,27", ",")

我們要裡面的 8,27 輪流站進去Num裡面
方便我們後續使用

當8進去Num之後
   餘數 = (Arr(1)(R, C) + Num - 1) Mod 49 + 1
我們繼續執行上面這段
Arr(1)(R,C) 是工作表上M2的位置也就是11
最後就變成
餘數 = (11+8-1) mod 49 +1
最後答案
餘數= 18+1

然後在進行下一個 27站出來
餘數 = (11+27-1) mod 49 +1
餘數= 38
最後再把 19跟38結合一起
就會變成
19,38

作者: n7822123 時間: 2021-7-25 21:22

回復 16# ziv976688

是儲存格裡面的數字喔~~Num只是個變數名稱而已

作者: ziv976688 時間: 2021-7-25 22:04

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

回復 20# singo1232001
謝謝S大您的詳細說明~
我研讀後~有問題再向您請教。
謝謝您

作者: ziv976688 時間: 2021-7-25 22:05

回復 21# n7822123
謝謝n大您的回覆~瞭解了

作者: ML089 時間: 2021-7-25 23:11

回復 17# ziv976688

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

準7進8 的 V2:AB2 資料有誤，你修改後在執行看看

作者: ML089 時間: 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" 做出來的資料有誤，你再查看看

作者: ziv976688 時間: 2021-7-25 23:59

回復 25# ML089
我還沒有注意到準7進8 的 V2:AB2 資料有誤

改為陣列.....修改後在執行看看~
4樓的貴解沒有看到修改的地方。
請教您 : 應該怎麼改?
謝謝您

PS : 不是我的電腦有問題就OK了~幾秒都沒有關係

DATA!VB 下列放置位置應該在迴圈之外
那版面的設定不就失效了

我自己先研習一下
不好意思事事麻煩您。
明天再說!
晚安!

作者: ML089 時間: 2021-7-26 09:04

回復 26# ziv976688

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

資料
計算
排版
列印

作者: ziv976688 時間: 2021-7-26 13:04

回復 13# n7822123
[attach]33762[/attach]
不好意思，可否請您幫我看一下~
只執行"標示底色"很OK(不到2秒)，
但如果再加上"餘數登錄"~ 測試N次，卻都要跑30秒上下~
為什麼會跑的這麼異常的慢 ?
是2003版本的關係嗎?
能改善嗎?
謝謝您

作者: ziv976688 時間: 2021-7-26 14:24

本帖最後由 ziv976688 於 2021-7-26 14:26 編輯

回復 27# ML089
[attach]33763[/attach]
花了半天~將您所賜教的解答檔，全部檢測完畢~
報告如下：
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 標示底色
我還想不出怎麼解決版面設定失效的問題

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

作者: 准提部林 時間: 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

作者: 准提部林 時間: 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

作者: ziv976688 時間: 2021-7-26 15:17

回復 31# 准提部林
版主 :
我本來是想研習各位大大的語法，所以針對各人的語法，我有不瞭解的地方頻頻發問~給大家添麻煩了~抱歉!

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

萬分感謝您的指導和幫忙

作者: ML089 時間: 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

作者: ziv976688 時間: 2021-7-26 23:09

回復 33# ML089
版主 :
餘數各取1測試成功

謝謝您耐心指導~感恩

您的加註~讓我受益良多

作者: ziv976688 時間: 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還真不易學，只是一個數值個數統計的小問題~就考倒我了

作者: ML089 時間: 2021-7-27 10:34

回復 26# ziv976688

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

[attach]33768[/attach]

作者: ML089 時間: 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

格式化部分能需要在微調

作者: ziv976688 時間: 2021-7-27 16:35

回復 37# ML089
xS.[A2] = IIf(N = 0, "", N & "個")
程式碼沒有錯~
為什麼"準6進7"和 "準7進8"的A2不一致 ?
進7的A2=0個；進8的A2="" =>不是A2都=""
請賜教!謝謝您

作者: ziv976688 時間: 2021-7-27 17:45

本帖最後由 ziv976688 於 2021-7-27 17:54 編輯

回復 37# ML089
版主:
全部OK了~跑完不到2秒~

謝謝您將全部的程式碼(含底色標示)重新整理~感恩

PS :38樓的回覆請不要理會~我沒有將36樓的範例檔，再改貼上37樓的貴解。
再次感謝您多日來的熱心幫忙和耐心指導~您辛苦了

作者: ML089 時間: 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)

作者: ziv976688 時間: 2021-7-27 18:06

本帖最後由 ziv976688 於 2021-7-27 18:07 編輯

回復 40# ML089
不好意思，是我沒有注意到要將36樓的貴範例檔，再貼上37樓的貴解

感謝您

作者: n7822123 時間: 2021-7-28 04:04

回復 28# ziv976688

標示底色、餘數登入都已經是跑各個工作表了

你好像又把這兩個寫在主程式的For 迴圈裡面，執行了N次一樣的操作~

作者: ziv976688 時間: 2021-7-28 06:07

回復 42# n7822123
多謝提醒~我再檢查看看。
謝謝您

作者: ziv976688 時間: 2021-7-28 06:15

本帖最後由 ziv976688 於 2021-7-28 06:25 編輯

回復 4# ML089
[attach]33773[/attach] =>可按清除鍵~重新測試。
版主 : 您好 !
請教您~
Module 3
先把列7 SP = (SP + xV.Offset(, -9)) Mod 49: If SP = 0 Then SP = 49  'V2+M2 mod 49
調整為SP = (xV.Offset(, -9) + SP) Mod 49: If SP = 0 Then SP = 49  'M2+V2 mod 49
以利作需求說明。

需求：
想將SP = (xV.Offset(, -9) + SP) Mod 49: If SP = 0 Then SP = 49  'M2+V2 mod 49
改為SP = (xV.Offset(, -9) - SP) Mod 49: If SP = 0 Then SP = 49  'M2-V2 mod 49
然後有二種方式的計算狀況 :
A式 : 當 -SP之後的差值=負數時，則SP自動轉為正數(即如=絕對值)
以函式作簡單說明~
EX : 準2進3!........準7進8!的D2=
=IF((V2<>"")*OR(IF(MOD(ABS(M2-V2),49),MOD(ABS(M2-V2),49),49)=($M$27:$S$27)),IF(MOD(ABS(M2-V2),49),MOD(ABS(M2-V2),49),49),"")
右拉再下拉填滿
EX :的A式_Ans (準2進3!)；…….其餘類推。

B式 : 當-SP之後的差值=負數時，則SP自動再+49轉為正數(即如=一般的函數計算)
以函式作簡單說明~
EX : 準2進3!........準7進8!的D2=
=IF((V2<>"")*OR(IF(MOD(M2-V2,49),MOD(M2-V2,49),49)=($M$27:$S$27)),IF(MOD(M2-V2,49),MOD(M2-V2,49),49),"")
EX :  B式_Ans (準2進3!)；…….其餘類推。

以上二種的計算方式之程式碼~懇請指導。
謝謝您^^

作者: ziv976688 時間: 2021-7-28 06:51

本帖最後由 ziv976688 於 2021-7-28 06:53 編輯

回復 30# 准提部林
[attach]33774[/attach] =>可按清除鍵~重新測試。
版主 : 您好 !
請教您~
Module 3
需求：
想將列10 Brr(i, j) = Brr(i, j) & "," & Format((Arr(i, j) + Val(A)) Mod 49, "00;;49")
改為 Brr(i, j) = Brr(i, j) & "," & Format((Arr(i, j) - Val(A)) Mod 49, "00;;49")
然後有二種方式的計算狀況 :
A式 : 當- Val(A)之後的差值=負數時，則Brr(i, j)自動轉為[colorBlue]=正數(即如=絕對值)
以函式作簡單說明~
EX : 準2進3!........準7進8!的D2=
=IF((V2<>"")*OR(IF(MOD(ABS(M2-V2),49),MOD(ABS(M2-V2),49),49)=($M$27:$S$27)),IF(MOD(ABS(M2-V2),49),MOD(ABS(M2-V2),49),49),"")
右拉再下拉填滿
EX :A式_Ans (準2進3!)；…….其餘類推。

B式 : 當- Val(A)之後的差值=負數時，則Brr(i, j)自動再+49轉為正數(即如=一般的函數計算)
以函式作簡單說明~
EX : 準2進3!........準7進8!的D2=
=IF((V2<>"")*OR(IF(MOD(M2-V2,49),MOD(M2-V2,49),49)=($M$27:$S$27)),IF(MOD(M2-V2,49),MOD(M2-V2,49),49),"")
EX : B式_Ans (準2進3!)；…….其餘類推。

以上二種的計算方式之程式碼~懇請指導。
謝謝您^^

作者: ML089 時間: 2021-7-28 11:01

回復 44# ziv976688

SP = (xV.Offset(, -9) - SP) Mod 49: If SP = 0 Then SP = 49  'M2-V2 mod 49

A式 : 當 -SP之後的差值=負數時，則SP自動轉為正數(即如=絕對值)
SP = ABS(xV.Offset(, -9) - SP) Mod 49: If SP = 0 Then SP = 49  'M2-V2 mod 49

B式 : 當-SP之後的差值=負數時，則SP自動再+49轉為正數(即如=一般的函數計算)
SP = (xV.Offset(, -9) - SP + 49) Mod 49: If SP = 0 Then SP = 49  'M2-V2 mod 49

作者: 准提部林 時間: 2021-7-28 11:45

回復 45# ziv976688

1)
Brr(i, j) = Brr(i, j) & "," & Format(ABS((Arr(i, j) - Val(A)) Mod 49), "00;;49")

2)
V= (Arr(i, j) - Val(A)) Mod 49
IF V<0 THEN V=V+49
Brr(i, j) = Brr(i, j) & "," & Format(V, "00;;49")

作者: ziv976688 時間: 2021-7-28 12:26

回復 46# ML089
回復 47# 准提部林
二位版主 :
不好意思，公式寫錯了

測試成功

謝謝二位版主的幫忙和指導~感恩

作者: ML089 時間: 2021-7-28 12:56

回復 48# ziv976688

B式 : 當-SP之後的差值=負數時，則SP自動再+49轉為正數(即如=一般的函數計算)
SP = (xV.Offset(, -9) - SP + 49) Mod 49: If SP = 0 Then SP = 49 'M2-V2 mod 49

若是
11-90 = -79，再+49變成 -30 ，還是負數怎麼辦?

作者: ziv976688 時間: 2021-7-28 14:03

本帖最後由 ziv976688 於 2021-7-28 14:13 編輯

回復 49# ML089
版主 :
謝謝您的提醒

For Each SP In Split(xV, ",")
:
:
Next
xV不是已限制在0 To 48了嗎?
還是我又錯了

如果我又誤解程式碼的意涵~懇請賜正。
謝謝您

准大的參數登錄(Module 2)
Sub 參數登錄()
Dim xS As Worksheet, xD, Arr(6), Brr, R&, i&, j%, k%, x%, N%, T$
Set xD = CreateObject("Scripting.Dictionary")
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))
      xD.RemoveAll
      R = xS.[ac65536].End(xlUp).Row - 1
      N = N + 1: If R < 1 Then GoTo s01
      ReDim Brr(1 To R - 1, 1 To 7)
      For k = 0 To N
         Arr(k) = xS.[ae2].Cells(1, k * 9 + 1).Resize(R, 7)
         For j = 1 To 7
            xD(Arr(k)(R, j) & "|" & k) = 1
         Next j
      Next k
      '--------------------------------------
      For i = 1 To R - 1
         For j = 1 To 7
            For x = 0 To 48
                  For k = 0 To N
                     ' T = (Arr(k)(i, j) + x) Mod 49 & "|" & k
                     V = (Arr(k)(i, j) - x) Mod 49
                     If V < 0 Then V = V + 49
                     T = V & "|" & k
                     If xD(T) = 0 Then GoTo x001
                  Next k
                  Brr(i, j) = Brr(i, j) & IIf(Brr(i, j) = "", "", ",") & x
x001:                   Next x
         Next j
      Next i
      '-------------------------------------
      With xS.[v2].Resize(R - 1, 7) '登錄位置
         .NumberFormatLocal = "@"
         .Value = Brr
      End With
s01:       Next
End Sub

作者: ziv976688 時間: 2021-7-28 14:32

回復 42# n7822123
已修正~
修正後執行正常(不到2秒)

謝謝您的指導和幫忙~感恩

作者: ML089 時間: 2021-7-28 15:50

回復 50# ziv976688

了解，數字若是0~48就沒有問題
因為之前寫公式有問過你，數字是否控制在99以下，所以有點誤會。

作者: ziv976688 時間: 2021-7-29 00:30

本帖最後由 ziv976688 於 2021-7-29 00:40 編輯

回復 52# ML089
版主 :
感謝您的關心

那時候~是提問A4:A52=D2:J26的餘數各取1
您要確定A欄是否為最多是2位數的整數?

沒有您耐心的幫我將程式碼流程全部重新整理，
我是無法順利完成本次各分拆項的問題需求~感恩

作者: ziv976688 時間: 2021-7-29 02:32

本帖最後由 ziv976688 於 2021-7-29 02:50 編輯

回復 13# n7822123
請教您 :
列9 餘數 = (Arr(1)(R, C) + Num - 1) Mod 49 + 1  '加算Mod(M2+V2,49)

如果將貴程式碼改為減算，並將其差值轉為絕對值，使其都為正數
餘數 = (Abs(Arr(1)(R, C) - Num) - 1) Mod 49 + 1    '減算Mod(ABS(M2-V2),49)
但這樣改~會有一個小Bug : 當餘數=0 時，不會自動轉為49
必須再加  If 餘數 = 0 Then 餘數 = 49

請問 :以貴原程式碼要將差值改為絕對值的正確語法 ?
謝謝您

作者: ziv976688 時間: 2021-7-29 03:41

本帖最後由 ziv976688 於 2021-7-29 03:45 編輯

回復 37# ML089
[attach]33777[/attach]
版主 :
不好意思，又有一個小Bug~
準5進6!A4=""
A4應該=46 。
懇請您賜正~謝謝您

作者: ML089 時間: 2021-7-29 13:51

本帖最後由 ML089 於 2021-7-29 13:54 編輯

回復 55# ziv976688

真不好意思，小BUG不斷。
Sub 餘數各取1()
Dim xD As Object, xS As Worksheet, xR As Range, SP, N
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 > 0 Then
         With xS.[A4].Resize(N)
            .Value = Application.Transpose(xD.keys)
            'N > 1時才需要排序，不然會錯
            If N > 1 Then .Sort key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
         End With
      End If
      xD.RemoveAll
Next
End Sub

作者: ziv976688 時間: 2021-7-29 14:47

本帖最後由 ziv976688 於 2021-7-29 15:14 編輯

回復 56# ML089

真不好意思，小BUG不斷。

版主 :
您不要這麼說，您願意指導，我已經是感激不盡了

要不是您不厭其煩的修正 Bug，我也沒機會學會正確的語法~
例如這一次的Bug，我是仔細的端詳整篇程式碼，但就是瞧不出 Bug是在哪裡?
也曾試將N>1改為N>=1，但失敗了~
結果是將N>0和N>1分別判斷就可以解決。

謝謝您的耐心指導和幫忙~感恩

PS : 54樓~ If 餘數 = 0 Then 餘數 = 49 的語法也是向您學習來的

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)