公式程式碼化 - Excel程式區 - 麻辣家族討論版版

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

17^#

發表於 2021-7-25 20:04 | 只看該作者

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

回復 14# ML089
測試成功

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

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

標示底色_ML089_V1.rar (107.08 KB)
謝謝您

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

16^#

發表於 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" 嗎?
還是只是變數 ?
謝謝您

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

15^#

發表於 2021-7-25 19:37 | 只看該作者

回復 12# n7822123
測試成功

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

版主 Rank: 7 Rank: 7 Rank: 7

ML089

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

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

14^#

發表於 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 三鍵輸入公式

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

13^#

發表於 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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

12^#

發表於 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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

帖子: 678
主題: 147
精華: 0
積分: 799
點名: 0
作業系統: win 8
軟體版本: MS 2003
閱讀權限: 50
性別: 男
註冊時間: 2016-2-9
最後登錄: 2022-1-20

11^#

發表於 2021-7-25 17:41 | 只看該作者

回復 10# ML089

標示底色_ML089.rar (105.69 KB) =>可按清除鍵測試
版主 :
您是不是誤解需求的意思了

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

版主 Rank: 7 Rank: 7 Rank: 7

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 三鍵輸入公式

帖子: 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之程式碼要如何修正 ?
謝謝您