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

本帖最後由 ken2192 於 2018-1-1 20:45 編輯

各位版友好，
以下是我在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

樓主熱帖

Kenny

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2018-1-2 07:48 | 只看該作者

回復 1# ken2192

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

ken2192

中學生 Rank: 2

帖子: 15
主題: 6
精華: 0
積分: 58
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2015-7-31
最後登錄: 2018-5-6

3^#

發表於 2018-5-6 16:44 | 只看該作者

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

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

Kenny

TOP