1234
返回列表 上一主題 發帖

[發問] VBA_請簡化程式碼。謝謝!

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
31# 跳轉到 »
發表於 2015-11-24 06:55 | 只看該作者
回復 29# Airman
有一個(含)以上的交集值(07,39)時
交集值 應有規律性,可讓程式去設定
試試看
  1. Option Explicit
  2. Private Sub CommandButton1_Click()
  3.     Dim b As Range, Rng As Range, E, C As Variant, Ar(), x_No, x As Variant
  4.     Dim xRng As Range, Color_Ar(), i As Integer
  5.     x_No = Array(7, 39)
  6.     Color_Ar = Array(4, 45, 8)
  7.     With Sheets(2)
  8.         .Activate   '將目前的工作表成為使用中的工作表。等同於按一下工作表索引標籤。
  9.         Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
  10.         Set Rng = .Range("J7:P" & .[R6] + 5)                '所複製資料的範圍
  11.         Set xRng = .Range("T7:T" & .[R6] + 5)               'T欄的範圍
  12.         If Application.Count(xRng) = 0 Then Exit Sub        'T欄沒有期數時離開程式
  13.         For Each b In xRng.SpecialCells(xlCellTypeConstants) 'T欄 [有期數的儲存格]範圍
  14.             Ar = Array(.Range("R" & b.Row).Value, .Range("R" & b.Row) - .[T3], .Range("R" & b.Row) - .[T3] * 2) '期別的陣列
  15.             '陣列:其在R欄的對應期數
  16.             For i = 0 To UBound(Ar)                 '陣列元素下限值從0開使
  17.                 For Each x In x_No                  '比對數字的迴圈
  18.                     C = Application.Match(x, Rng.Rows(Ar(i)), 0) '找到傳回數字
  19.                     If IsNumeric(C) Then Rng.Rows(Ar(i)).Cells(C).Interior.ColorIndex = Color_Ar(i)
  20.                 Next
  21.             Next
  22.         Next
  23.         .[a1].Select  '滑鼠停留在Sheets(2)的 A1
  24.     End With
  25. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
32#
發表於 2015-11-24 09:54 | 只看該作者
本帖最後由 Airman 於 2015-11-24 10:01 編輯

回復 31# GBKEE
GBKEE超版大:您好!
不好意思，您還將程式碼全加註解~辛苦您了!感恩

非常接近了!只剩下交集值的定義有誤差~
先假設ARR=.Range("R" & b.Row),.Range("R" & b.Row)-T$3, .Range("R" & b.Row)-T$3*2三個期數的範圍，以利說明。

目前貴程式是依據x_No = Array(m, n)是預設之固定的搜尋值~
即當m填入07，n填入39,則將在ARR有顯示07或39的儲存格各標示底色(不需要3個期數同時都有)；
又如當m填入01，n填入49,則將在ARR有顯示01或49的儲存格各標示底色(不需要3個期數同時都有)；....其餘以此類推。

本體需求的交集值是浮動的(即非預設的)~
即是依據ARR的3個期數是否同時都有相同數字來決定︰如果3個期數都有相同的數字時，則該相同數字即為交集值~
EX1_即當ARR的交集值為01(即必須3個期數同時都有01)時，則3個期數顯示01的儲存格各標示底色；
EX2_即當ARR的交集值為07,39(即必須3個期數同時都有07,39)時，則3個期數顯示07,39的儲存格各標示底色；
EX3_當ARR的交集值為08,20,40(即必須3個期數同時都有08,20,40)時，則3個期數顯示08,20,40的儲存格各標示底色；
EX4_當ARR都沒有交集值(即3個期數沒有同時都有相同的數字)時，則3個期數的儲存格都為無底色。..... 其餘以此類推。

以上 謹供參考!謝謝您!

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
33#
發表於 2015-11-24 11:10 | 只看該作者
本帖最後由 准提部林 於 2015-11-24 12:18 編輯

回復 30# Airman


x_No = Array(7, 39)　超板還是以為7,39是〔已知〕條件，所以我才說要加註說明！！^ ^

試著以如下去解說：
有Ａ．Ｂ．Ｃ三區，每區７格，每區各有７個１∼４９不重覆數字，
找出這三區〔共有〕的數字並分別填入底色 （共有數字須先行檢測，無預設值），
例如下方範例，檢測後取得共同數字為：０７．３９．１３
Ａ區：
07121728394313

Ｂ區：
01071339424549

Ｃ區：
07091320213949

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
#11 是以〔一個數字〕去比封三區，所以較簡單，
此需求是７個數字逐一比對三區，1 To 3 及 1 To 7 迴圈省不了，因為欄位不一樣，
若要求數字及欄位相同，即如#27，用 1 To 7 迴圈即可，反而較省事；
以此需求的迴圈不算大，應還不太影響運行速度，
若減少迴圈以函數代替，也並不見得較好，畢竟函數的效率有時會降低速度∼∼

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
34#
發表於 2015-11-24 11:45 | 只看該作者
回復 33# 准提部林
准大:
呵~呵~還是您的解說既簡且清~小弟承教了~希望小弟下次的說明能更精準

原是想程式碼同一式體，既然您說沒有特別益處~小弟就不再執著了。

謝謝您的耐心回覆與說明~感恩

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
35#
發表於 2015-11-24 13:13 | 只看該作者
本帖最後由 GBKEE 於 2015-11-24 14:45 編輯

回復 34# Airman

參考准提部林 版主說明
試試看
  1. Option Explicit
  2. Dim Sh As Worksheet '這模組的私用變數
  3. Private Sub CommandButton1_Click()
  4.     Dim b As Range, Rng As Range
  5.     Dim xRng(1 To 2) As Range
  6.     With Sheets("Sheet1") '要呈現的工作表
  7.         Sheets("DATA").Range("J7", "P" & .[R6] + 5).Copy .[J7]
  8.         Set Rng = .Range("J7:P" & .[R6] + 5)                   '所複製資料的範圍
  9.         Rng.Interior.ColorIndex = xlNone
  10.         Set xRng(1) = .Range("T7:T" & .[R6] + 5)               'T欄的範圍
  11.         If Application.Count(xRng(1)) = 0 Then Exit Sub        'T欄沒有期數時離開程式
  12.         
  13.         Set Sh = Sheets.Add(Sheets(1))                         '增加一工作表
  14.         Application.ScreenUpdating = False                     '如果螢幕更新功能是開啟的則為 True
  15.         For Each b In xRng(1).SpecialCells(xlCellTypeConstants) 'T欄 [有期數的儲存格]範圍
  16.             Ex_ChiCK Union(Rng.Rows(.Range("R" & b.Row)), Rng.Rows(.Range("R" & b.Row) - .[T3]), Rng.Rows(.Range("R" & b.Row) - .[T3] * 2))  '期別的陣列
  17.             'Ex_ChiCK Union(Rng.Rows(.Range("R" & b.Row) - .[T3] * 2), Rng.Rows(.Range("R" & b.Row) - .[T3]), Rng.Rows(.Range("R" & b.Row)))  '倒轉期別
  18.         Next
  19.         .Activate   '將目前的工作表成為使用中的工作表。等同於按一下工作表索引標籤。
  20.         .[a1].Select  '滑鼠停留在Sheets(2)的 A1
  21.     End With
  22.     Application.DisplayAlerts = False  '如果巨集在執行時 Microsoft Excel 顯示特定的警告和訊息則為 True
  23.     Sh.Delete                          '刪除:工作表
  24.     Application.DisplayAlerts = True
  25.     Application.ScreenUpdating = True
  26. End Sub
  27. Private Sub Ex_ChiCK(Rng As Range)  '副程式 須傳送參數
  28.     Dim Ar(), i As Variant, E As Variant, X As Variant, M As Integer
  29.     Ar = Array(4, 45, 8)
  30.     Rng.Copy Sh.[a1]             '複製三期資料
  31.     For i = 1 To 49
  32.         X = Application.CountIf(Sh.UsedRange, i)  'x = 3 :同一號碼三期都出現
  33.         If X = 3 Then E = E & IIf(E <> "", ",", "") & i  '紀錄號碼
  34.     Next
  35.     X = Split(E, ",")        '出現3次的號碼,置入陣列
  36.     For Each E In X
  37.         For i = 1 To Rng.Areas.Count
  38.             '傳回 Areas 集合，此集合代表多重範圍中的所有範圍
  39.             M = Application.Match(Val(E), Rng.Areas(i).Cells, 0)
  40.             Rng.Areas(i).Cells(M).Interior.ColorIndex = Ar(i - 1) '依範圍傳回的顏色
  41.         Next
  42.     Next
  43. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
36#
發表於 2015-11-24 14:20 | 只看該作者
本帖最後由 Airman 於 2015-11-24 14:24 編輯

回復 35# GBKEE
GBKEE超版大:您好!
不好意思~只剩標示底色的問題了~
假設:A區=.Range("R" & b.Row)；B區=.Range("R" & b.Row)-T$3；C區=.Range("R" & b.Row)-T$3*2；
則3區的共有數字，依分區分別標示4號,45號,8號底色~即A區標示4號底色；B區標示45號底色；C區標示8號底色 ~
EX_1:
C區(72)：         07        10        13        20        21        39        18

Ｂ區(81)：        01        07        13        39        42        45        12

A區(90)：        07        12        17        28        40        41        49

EX_2:
C區(72)：         07        09        11        20        21        39        12

Ｂ區(81)：        01        07        13        39        42        45        10

A區(90)：        07        12        17        28        40        13        39

EX_3:
C區(72)：         07        09        13        20        21        39        12

Ｂ區(81)：        01        07        13        39        42        45        12

A區(90)：        07        10        17        28        40        13        39


EX_4:
C區(72)：         07        09        13        20        21        39        12

Ｂ區(81)：        01        07        13        39        42        45        12

  A區(90)：        07        12        17        28        40        13        39

.....其餘以此類推

以上 謹供參考!謝謝您!

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
37#
發表於 2015-11-24 21:07 | 只看該作者
不是簡化，另一種寫法，比原使用３層迴圈更不易理解，參考罷：

RW = Array(b(1, -1), b(1, -1) - .[T3], b(1, -1) - .[T3] * 2)
For y = 1 To 3: Set R(y) = .[J:P].Rows(RW(y - 1) + 6).Cells: Next y
Dim M(1 To 3)
For k = 1 To 7
　　M(1) = k
　　For y = 2 To 3
　　　　M(y) = Application.Match(R(1)(k), R(y), 0)
　　　　If IsError(M(y)) Then M(1) = 0: Exit For
　　　　'If M(y) <> M(1) Then M(1) = 0: Exit For　'若要求〔同欄〕，加入這行　
　　Next y
　　If M(1) > 0 Then
　　　For y = 1 To 3: R(y)(M(y)).Interior.ColorIndex = Array(4, 45, 8)(y - 1): Next
　　End If
Next k

TOP

Airman

帖子
315 
主題
51 
精華
0 
積分
367 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-29 
最後登錄
2021-10-12 
38#
發表於 2015-12-9 09:25 | 只看該作者
回復 37# 准提部林
准大:
感謝您費神再賜另解

PS:本想只以短消息向您致謝即可，避免虛取點數，但無奈小弟還是不習慣~總覺得問與答之間少個句點

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
1234
返回列表 上一主題