Сброс / повторное использование целевого диапазона для электронной таблицы - PullRequest
Новая
       16

Сброс / повторное использование целевого диапазона для электронной таблицы

0 голосов
/ 02 апреля 2019

Я пытаюсь написать макрос, который будет отправлять электронное письмо, если выбран определенный диапазон и соответствует определенным критериям.У меня есть несколько почтовых сабвуферов, которые будут вызываться в зависимости от того, какой диапазон выбран / активирован.Я пытаюсь использовать метод Intersect (Range, Target), чтобы ограничить, какой диапазон будет вызывать какой почтовый саб.У меня проблема в том, что мой код по умолчанию всегда соответствует первому диапазону в листе, но мне нужно просто использовать активный диапазон.Я включил образец моего кода ниже. 

Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub

'Checklist Setup Review
Dim LastRow As Long
Dim i As Long
Dim xRg As Range
Dim x As String
Dim NewRng As Range

LastRow = Cells(Rows.Count, "H").End(xlUp).Row
For i = 1 To LastRow
    If UCase(Cells(i, "H").Value) = "P" Then
        If NewRng Is Nothing Then
            Set NewRng = Cells(i, "A")
        Else
            Set NewRng = Union(NewRng, Cells(i, "A"))
        End If
    End If
Next i

'Initial Lidar Review
Dim LastRow1 As Long
Dim e As Long
Dim NewRng1 As Range

LastRow1 = Cells(Rows.Count, "I").End(xlUp).Row
For e = 1 To LastRow1
    If UCase(Cells(e, "I").Value) = "P" Then
        If NewRng1 Is Nothing Then
            Set NewRng1 = Cells(e, "A")
        Else
            Set NewRng1 = Union(NewRng1, Cells(e, "A"))
        End If
    End If
Next e

'Initial Ground Macro Review
Dim LastRow2 As Long
Dim xRg2 As Range
Dim j As Long
Dim NewRng2 As Range

LastRow2 = Cells(Rows.Count, "J").End(xlUp).Row
For j = 1 To LastRow2
    If UCase(Cells(j, "J").Value) = "P" Then
        If NewRng2 Is Nothing Then
            Set NewRng2 = Cells(j, "A")
        Else
            Set NewRng2 = Union(NewRng2, Cells(j, "A"))
        End If
    End If
Next j

'Call Email subs
If xRg Is Nothing Then
    Set xRg = Intersect(NewRng, Target)
    x = True
    For Each r In NewRng
        If r.Value <> "Pass" And r.Value <> "Complete" Then
            x = False
        End If
    Next r
    If x = True Then
        MsgBox "Project Setup Review Complete: Auto Email Sent."
        Call SetupReview_Email
    End If
ElseIf xRg Is Nothing Then
    Set xRg = Intersect(NewRng1, Target)
    If xRg Is Nothing Then Exit Sub
    x = True
    For Each r In NewRng1
        If r.Value <> "Pass" And r.Value <> "Complete" Then
            x = False
        End If
    Next r
    If x = True Then
        MsgBox "Intial Lidar Review Completed: Auto Email Sent."
        InitialLidarReview_Email
    End If
ElseIf xRg Is Nothing Then
    Set xRg = Intersect(NewRng2, Target)
    For Each r In NewRng2
        If r.Value <> "Pass" And r.Value <> "Complete" Then
            x = False
        End If
    Next r
    If x = True Then
        MsgBox "Ground Macro Review Completed: Auto Email Sent."
        Call GroundMacro_Email
    End If
End If

End Sub

1 Ответ

0 голосов
/ 02 апреля 2019

Делая это немного поспешно, но, надеюсь, вы получите суть. Должны ли операторы If фактически проверять, является ли Intersect NOT Nothing? 

Set xRg = Intersect(NewRng, Target)
If xRg Is Nothing Then
    'stuff
Else
    Set xRg = Intersect(NewRng1, Target)
    If xRg Is Nothing Then
        'stuff
    Else
        Set xRg = Intersect(NewRng2, Target)
        If xRg Is Nothing Then
            'stuff
        End If
    End If
End If
...