Question

我已成功编写了两个宏来根据工作表中的单元格值自动发送电子邮件（基本上作为提醒系统）。范围重叠，一个子用于在单元格值达到0时发送电子邮件，另一个用于较小范围的单元格，用于在单元格报告1到5之间的范围（包括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

Answer 1

这是一种蛮力方法，但我认为你的代码可以缩短，因为有共性

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

Answer 2

通过一些修改，请尝试以下两个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

难以在一个Excel工作表中合并2 x Private Sub Worksheet_Change（ByVal Target As Range）

2 个答案: