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

准提部林

三列〔同時〕出現 [R5]，填入不同底色：

Private Sub CommandButton1_Click()
Dim b As Range, RW, y%
With Sheets(2)
　　　Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
　　　Application.Goto .Range("T7:T" & .[R7].End(xlDown).Row)　'不用Select，直接跳選目標區　
　　　RW = Array(.[T5], .[T5] - .[T3], .[T5] - .[T3] * 2)　'３區的期數陣列　
　　　For Each b In Selection
　　　　　If b <> "" Then
　　　　　If .Range("R" & b.Row) + 1 = .[T5] And .Range("R" & b.Row) - .[T3] * 2 > 6 Then
　　　　　　　Dim R(1 To 3) As Range, U%
　　　　　　　For y = 1 To 3
　　　　　　　　　Set R(y) = .[J:P].Rows(RW(y - 1) + 6).Find(.[R5], Lookat:=xlWhole)　'標定３區[R5]值的儲存格　
　　　　　　　　　If R(y) Is Nothing Then U = 1: Exit For　'若任一區不含 [R5]，以 U=1 表示，跳出　
　　　　　　　Next y
　　　　　　　If U = 0 Then　'３區皆含[R5]
　　　　　　　　　For y = 1 To 3: R(y).Interior.ColorIndex = Array(4, 45, 8)(y - 1): Next　'標示〔個別〕底色　
　　　　　　　　　With Union(R(1), R(2), R(3)).Font: .ColorIndex = 3: .FontStyle = "粗體": End With　'設定文字　
　　　　　　　End If
　　　　　End If
　　　　　End If
　　　Next b
　　　.[A1].Select
End With
End Sub

可簡化的不多，參考超板的方法減少三層的迴圈而已！　

Airman

回復 11# 准提部林
准大:
您的助人熱誠實在令小弟折服

少了3個迴圈變數就少了許多，除了簡化程式碼，效率也提升很多~，
尤其是不用Select~對於效率的提升更是顯著。

萬分感謝您的耐心教導和費神的再加程式註解~小弟受益良多~感恩再感恩....

准提部林

回復 12# Airman


只憑所提供的程式碼, 要回溯原需求規則, 除費時費眼力外, 並非易事,
還好有超板專業老手打先鋒, 我插花寫不同需求罷了~~

Airman

回復 13# 准提部林
准大:
再次謝謝您的費神。

可否另外再請您賜教:
如何將Set R(y) = .[J:P].Rows(RW(y - 1) + 6).Find(.[R5], Lookat:=xlWhole)　改為~
"標定３區[R5]值的儲存格為相同欄位"　。
謝謝您!

為了免於重述繁(煩)複的說明及多占版面，所以未另開題請益~敬請見諒!感恩!

Airman

需求︰
請將『搜尋在R7(=90期),R7-T3(=81期),R7-T3*2(=72期)三個期數同時有一個(含)以上的交集值(=07,39)；並分別將其標示4,45,8號底色』的列19~列33程式碼~簡化為如列7~列17之程式碼的型態寫法~
EX︰RV = Array(.Range("R" & b.Row),.Range("R" & b.Row)- .[T3],.Range("R" & b.Row)- .[T3] * 2)  '另３區的期數陣列

詳如附件~ TEST_2.rar (61.49 KB)

下載次數: 7

2015-11-23 06:15

敬請各位大大不吝指導~感恩!

GBKEE

回復 11# 准提部林
字串用 InStr , Split

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, E As Variant, C As Variant, Ar As String
   
4.     Ar = "4,45,8"
   
5.     With Sheets(2)
   
6.         Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
   
7.         Set Rng = .[J7].Resize(.[J7].End(xlDown).Row, 7)
   
8.         For Each E In Array(.[T5], .[T5] - .[T3], .[T5] - .[T3] * 2)
   
9.                             '.T5,T5-T3,T5-T3*2 '91,82,73
   
10.             C = Application.Match(.[R5], Rng.Rows(E), 0) '找到傳回數字
    
11.             If IsNumeric(C) Then
    
12.                 With Rng.Rows(E).Cells(C)
    
13.                     .Interior.ColorIndex = Split(Ar, ",")(0)
    
14.                     .Font.ColorIndex = 3
    
15.                     .Font.FontStyle = "粗體"
    
16.                 End With
    
17.                 If InStr(Ar, ",") Then Ar = Mid(Ar, InStr(Ar, ",") + 1)
    
18.             End If
    
19.         Next
    
20.     End With
    
21. End Sub

複製代碼

Airman

回復 16# GBKEE
GBKEE超大:早安!
不好意思，先請教:要讓貴程式在結束後，滑鼠停留在A1，要怎麼寫?(在End With插入.[A1].Activate或.[A1].Select都不對 )

回應貴留言:
小弟的意思是將列19~列33程式碼移除，簡化成如類似列7~列17程式碼型態的寫法。
當然以貴寫法更為簡化。
如不嫌棄~敬請您惠予賜教!感恩

GBKEE

回復 17# Airman

1. With Sheets(2)
   
2.    ' 如准提部林版主 的
   
3.     Application.Goto .Range("T7:T" & .[R7].End(xlDown).Row)　'不用Select，直接跳選目標區　
   
4.    '或 .Activate   
   
5.   '或 .Select
   
6.    '使Sheets(2) 為作用中工作頁,儲存格才可用.Activate 或.Select
   
7.     '
   
8.     .[A1].Activate   
   
9. '或.[A1].Select
   
10. End With

複製代碼

請在指明要簡化的程式碼在哪裡

Airman

回復 18# GBKEE
GBKEE超大:您好!
抱歉!小弟說的太囉嗦了，讓您誤解了~重新說明如下:
請教:
以貴#13的程式碼，如果要再增加~
1.『搜尋在R7(=90期),R7-T3(=81期),R7-T3*2(=72期)三個期數同時有一個(含)以上的交集值(=07,39)；並分別將其標示4,45,8號底色』~
應該怎麼再增寫?
2.程式執行結束後，滑鼠停留在A1，請問要怎麼增寫?

以上敬請惠予賜教!謝謝您!

GBKEE

回復 19# Airman
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, E As Variant, C As Variant, Ar As String, x_No, x As Variant
   
4.     x_No = Array(7, 39)
   
5.     Ar = "4,45,8"
   
6.     With Sheets(2)  '
   
7.     'With Sheets("Sheet1")
   
8.         .Activate   '將目前的工作表成為使用中的工作表。等同於按一下工作表索引標籤。
   
9. 
   
10.         Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
    
11.         Set Rng = .[J7].Resize(.[J7].End(xlDown).Row, 7)
    
12.         For Each E In Array(.[T5].Value, .[T5] - .[T3], .[T5] - .[T3] * 2) '期別的迴圈
    
13.             '『搜尋在R7(=90期),R7-T3(=81期),R7-T3*2(=72期)三個期數~
    
14.             '.T5,T5-T3,T5-T3*2 '91,82,73 請修改公式
    
15.             
    
16.             For Each x In x_No   '比對數字的迴圈
    
17.                 C = Application.Match(x, Rng.Rows(E), 0) '找到傳回數字
    
18.                 If IsNumeric(C) Then
    
19.                     With Rng.Rows(E).Cells(C)
    
20.                         .Interior.ColorIndex = Split(Ar, ",")(0)
    
21.                         .Font.ColorIndex = 3
    
22.                         .Font.FontStyle = "粗體"
    
23.                     End With
    
24.                 End If
    
25.             Next
    
26.             If InStr(Ar, ",") Then Ar = Mid(Ar, InStr(Ar, ",") + 1)
    
27.         Next
    
28.         .[a1].Select  '滑鼠停留在Sheets(2)的 A1
    
29.     End With
    
30. End Sub

複製代碼