难以合并2 x私人小组Worksheet_Change（BYVAL目标作为范围）在一个Excel工作表

我已经成功编写了两个macros，基于表单中的单元格值（基本上作为提醒系统）自动发送电子邮件。 范围重叠，一个小组打算发送一个电子邮件，当单元格达到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 = "[e-mail]" .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 = "[e-mail]" .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 

Answer 1

通过一些修改，请尝试下面的两个Worksheet_Change事件的组合代码。

我添加了一个variablesEmailType ，用来检查修改过的单元格是否通过了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 = "[e-mail]" .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 

Answer 2

这是暴力的方法，但我认为你的代码可以缩短，因为有共同点

 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 = "[e-mail]" .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 = "[e-mail]" .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