[發問] EXCEL VBA 如何將重複的程式合併

ken2192

各位版友好，
以下是我在excel vba中，某一檔股票某條件成立之後，自動在固定儲存格裡累加次數，但excel中會有50檔的股票，於是我只能複製貼上一樣的指立，並修改M9->M10。
但由於太繁瑣且要應用在9-50列，請問版友我如何將重複的指令合併在同一個程式裡，每檔股票成單獨事件自動去累加!!


Private Sub Worksheet_Change(ByVal Target As Range)
Call script1(Target)
Call script2(Target)
Call script3(Target)
Call script4(Target)
End Sub
--------------------------------------------------------------
Private Sub script1(ByVal Target As Range)
If Target.Cells.Address = "$M$9" Then
If [M9] >= [P9] * 0.01 Then
[L9] = [M9] / [M9] + [L9]
End If
End If
End Sub
------------------------------------------------------------------
Private Sub script2(ByVal Target As Range)
If Target.Cells.Address = "$M$10" Then
If [M10] >= [P10] * 0.01 Then
[L10] = [M10] / [M10] + [L10]
End If
End If
End Sub
--------------------------------------------------------------------
Private Sub script3(ByVal Target As Range)
If Target.Cells.Address = "$M$11" Then
If [M11] >= [P11] * 0.01 Then
[L11] = [M11] / [M11] + [L11]
End If
End If
End Sub
---------------------------------------------------------------------
Private Sub script4(ByVal Target As Range)
If Target.Cells.Address = "$M$12" Then
If [M12] >= [P12] * 0.01 Then
[L12] = [M12] / [M12] + [L12]
End If
End If
End Sub

ken2192

If IsNumeric(.Cells) And .Cells >= .Cells(1, 4) * 0.01 Then

此寫法出現偵錯訊息，無法順利跑出!!可否請版主在幫我過目一下

GBKEE

回復 1# ken2192

1. Option Explicit
   
2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
3.     Dim Rng As Range
   
4.     Set Rng = [m9:m50] '**M9,M10,,M49,M50 。 要應用在9-50列
   
5.     If Not Intersect(Rng, Target) Is Nothing Then
   
6.     '**Intersect 方法 例特定傳回 Range 物件，此物件代表兩個或多個範圍重疊的矩形範圍。
   
7.     '**expression.Intersect(Arg1, Arg2, ...)
   
8.         With Target  '** Target是[m9:m50]中的儲存格
   
9.             If IsNumeric(.Cells) And .Cells > .Cells(1, 4) * 0.01 Then .Cells(, 0) = .Cells(, 0) + 1
   
10.             '**Cells(1, 4) ---以M欄為基準-> 4=P欄,
    
11.             '**.Cells(, 0) => .Cells(1, 0) ---以M欄為基準->0=L欄,
    
12.         End With
    
13.     End If
    
14. End Sub

複製代碼