[英]Difficulty merging 2 x Private Sub Worksheet_Change (ByVal Target As Range) in one Excel sheet
我已經成功地編寫了兩個宏，用於基於工作表中的單元格值自動進行電子郵件發送（基本上作為提醒系統）。 范圍重疊，一個子單元旨在當單元格的值為0時發送電子郵件，另一個子單元格較小的單元格范圍，並且當單元格的報告范圍在1-5之間（包括端值在內）時，用於發送電子郵件）。
我可以讓潛艇單獨工作沒問題，但是當我試圖將兩者合並時，我的知識非常有限。 要么根本不起作用，要么只能部分起作用。
如果有人可以幫助我，我將非常感謝，因為我很茫然！ 這兩個子代碼如下：
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D122:D128,D131:D133,D138,D140,D144,D188,D191:D192,D217:D220,D294,D159:D167"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value > 0 Then
If IsNumeric(Target.Value) And Target.Value < 6 Then
zRow = Target.Row
zValno = Cells(zRow, "B")
zValname = Cells(zRow, "C")
zValInno = Cells(zRow, "D")
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = ""
strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now low. This value is now " & zValInno & "."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
On Error Resume Next
With OutMail
.to = "abc@anyoldemail.com"
.CC = ""
.BCC = ""
.Subject = "LOW VALUE: " & zValno & " is now low."
.Body = strbody
.Attachments.Add ("C:\reportlog.txt")
.Send
End With
On Error GoTo 0
zSent = zSent + 1
saywhat = "processing " & zSent & " of " & zCount
Application.StatusBar = saywhwat
Application.StatusBar = ""
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
End If
End Sub
和
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D4:D100,G4:G100,J4:J99"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 1 Then
zRow = Target.Row
zValno = Cells(zRow, "B")
zValname = Cells(zRow, "C")
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = ""
strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now reporting nil."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
On Error Resume Next
With OutMail
.to = "abc@anyoldemail.com"
.CC = ""
.BCC = ""
.Subject = "NULL ALERT: " & zValno & " is now reporting nil."
.Body = strbody
.Attachments.Add ("C:\reportlog.txt")
.Send
End With
On Error GoTo 0
zSent = zSent + 1
saywhat = "processing " & zSent & " of " & zCount
Application.StatusBar = saywhwat
Application.StatusBar = ""
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
End Sub
這是蠻力方法，但是我認為您的代碼可以縮短，因為存在一些共性
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D122:D128,D131:D133,D138,D140,D144,D188,D191:D192,D217:D220,D294,D159:D167"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value > 0 Then
If IsNumeric(Target.Value) And Target.Value < 6 Then
zRow = Target.Row
zValno = Cells(zRow, "B")
zValname = Cells(zRow, "C")
zValInno = Cells(zRow, "D")
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = ""
strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now low. This value is now " & zValInno & "."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
On Error Resume Next
With OutMail
.to = "abc@anyoldemail.com"
.CC = ""
.BCC = ""
.Subject = "LOW VALUE: " & zValno & " is now low."
.Body = strbody
.Attachments.Add ("C:\reportlog.txt")
.Send
End With
End If
End If
ElseIf Not Application.Intersect(Range("D4:D100,G4:G100,J4:J99"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 1 Then
zRow = Target.Row
zValno = Cells(zRow, "B")
zValname = Cells(zRow, "C")
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = ""
strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now reporting nil."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
On Error Resume Next
With OutMail
.to = "abc@anyoldemail.com"
.CC = ""
.BCC = ""
.Subject = "NULL ALERT: " & zValno & " is now reporting nil."
.Body = strbody
.Attachments.Add ("C:\reportlog.txt")
.Send
End With
End If
End If
On Error GoTo 0
zSent = zSent + 1
saywhat = "processing " & zSent & " of " & zCount
Application.StatusBar = saywhwat
Application.StatusBar = ""
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
進行一些修改后，嘗試對兩個Worksheet_Change事件使用下面的組合代碼。
我添加了一個變量EmailType ，用於檢查修改后的單元格是否通過了2個條件之一，然后得到的值是1或2。
然后，根據EmailType修改電子郵件參數。
碼
Private Sub Worksheet_Change(ByVal Target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim mailSubject As String '<-- added this String variable to differ on 2 scenarios
Dim EmailType As Long '<-- use variable to see if passed the 2 criterias in the original code
EmailType = 0 '<-- init value
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D122:D128,D131:D133,D138,D140,D144,D188,D191:D192,D217:D220,D294,D159:D167"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value > 0 And Target.Value < 6 Then
EmailType = 1 '<-- Email Type = 1
End If
End If
If Not Application.Intersect(Range("D4:D100,G4:G100,J4:J99"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 1 Then
EmailType = 2 '<-- Email Type = 2
End If
End If
If EmailType = 0 Then Exit Sub '< didn't pass any of the criterias >> Exit Sub
zValno = Range("B" & Target.Row)
zValname = Range("C" & Target.Row)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Select Case EmailType
Case 1
zValInno = Cells("D" & Target.Row) '<-- this value exists on for Email Type 1
mailSubject = "LOW VALUE: " & zValno & " is now low." '<-- mail subject for email type 1
strbody = ""
strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now low. This value is now " & zValInno & "."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
Case 2
mailSubject = "NULL ALERT: " & zValno & " is now reporting nil." '<-- mail subject for email type 2
strbody = ""
strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now reporting nil."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
strbody = strbody & vbCr & vbCr
strbody = strbody & "Blah, blah, blah."
End Select
' ======= from here untill the end the same code, just using different values found per Email Type =======
On Error Resume Next
With OutMail
.to = "abc@anyoldemail.com"
.CC = ""
.BCC = ""
.Subject = mailSubject
.Body = strbody
.Attachments.Add ("C:\reportlog.txt")
.Send
End With
On Error GoTo 0
zSent = zSent + 1
saywhat = "processing " & zSent & " of " & zCount
Application.StatusBar = saywhat
Application.StatusBar = ""
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
如何在一個工作表中合並兩個私有子工作表_Change（按ByVal目標作為范圍）？
[英]How Does One Combine two Private Sub Worksheet_Change(ByVal Target As Range) in One Work Sheet?
如何在一張紙中使用多個私有子 Worksheet_Change(ByVal Target As Range)
[英]How to use Multiple Private Sub Worksheet_Change(ByVal Target As Range) in one sheet
Private Sub Worksheet_Change(ByVal Target As Range) 不起作用
[英]Private Sub Worksheet_Change(ByVal Target As Range) not working
Private Sub Worksheet_Change（ByVal Target As Range）並不總是有效
[英]Private Sub Worksheet_Change(ByVal Target As Range) not working always
將2個“ Private Sub Worksheet_Change（按目標的ByVal目標）”合並為1個
[英]Combining 2 “Private Sub Worksheet_Change(ByVal Target As Range)” into 1
合並兩個 Private Sub Worksheet_Change(ByVal Target As Range)
[英]Combine two Private Sub Worksheet_Change(ByVal Target As Range)
在一個工作表中運行多個'Private Sub Worksheet_Change（ByVal Target As Range）'
[英]Running multiple 'Private Sub Worksheet_Change(ByVal Target As Range)' in one worksheet
合並兩個“Private Sub Worksheet_Change(ByVal Target As Range)”
[英]Combine two "Private Sub Worksheet_Change(ByVal Target As Range)"
從公共子調用（運行）私有子worksheet_Change（ByVal目標為范圍）
[英]Calling(run) a private Sub worksheet_Change(ByVal Target As Range) from public sub
“ Private Sub Worksheet_Change（ByVal Target As Range）”-需要幫助re：range
[英]“Private Sub Worksheet_Change(ByVal Target As Range)” -need help re: range
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.