[英]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.