VBA продолжает работать, мне нужно нажать «es c» для завершения кода - PullRequest
Новая
       33

VBA продолжает работать, мне нужно нажать «es c» для завершения кода

0 голосов
/ 20 марта 2020

'Просто пытаюсь найти способ очистить код, чтобы мне не нужно было нажимать es c eveytime.

Sub Email_From_Excel_Basic()

Dim emailApplication As Object
Dim emailItem As Object
Dim mymsg As String
Dim cell As Range

Application.ScreenUpdating = False
Set emailApplication = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Worksheets("owssvr").Columns("S").Cells
    Set emailItem = emailApplication.CreateItem(0)

' Они говорят об ошибке находится в этих двух строках ниже. (IF и Cells) 

    If cell.Value Like "?*@?*.?*" And _
    Cells(cell.Row, "T") = "Yes" Then

'Следующая часть ниже должна быть в порядке. 

        With emailItem

        .To = Cells(cell.Row, "R").Value & ";" & Cells(cell.Row, "S").Value
        .CC = Cells(cell.Row, "S").Value & ";" & Cells(cell.Row, "S").Value & ";" & Cells(cell.Row, "S").Value

        .Subject = "Status update on your recent order"

        mymsg = "Dear " & Cells(cell.Row, "A").Value & " team," & vbNewLine & vbNewLine
        Dim stts As String
        If Cells(cell.Row, 4).Value = "1. New Order" Then
            stts = "Your order has been received and will be processed."
        ElseIf Cells(cell.Row, 4).Value = "2. Shipped" Then
            stts = "Your order has been shipped"
        ElseIf Cells(cell.Row, 4).Value = "3. In-Process" Then
            stts = "Your order has been received. We are waiting on information to confirm your order."
        ElseIf Cells(cell.Row, 4).Value = "5. Approved" Then
            stts = "Your order is approved to ship."
        Else
        End If

        mymsg = mymsg & "Status: " & stts & vbNewLine
        mymsg = mymsg & "Expected delivery: " & Cells(cell.Row, "AF").Value & vbNewLine & vbNewLine
        mymsg = mymsg & "Project contact: " & Cells(cell.Row, "Z").Value & vbNewLine
        mymsg = mymsg & "Email: " & Cells(cell.Row, "AA").Value & vbNewLine
        mymsg = mymsg & "Phone: " & Cells(cell.Row, "AB").Value & vbNewLine & vbNewLine
        mymsg = mymsg & "*This is only an estimate. Please reach out to your project contact for further information." & vbNewLine & vbNewLine
        mymsg = mymsg & "Best regards" & vbNewLine & vbNewLine
        .Body = mymsg
        .Send

' Может ли проблема быть в очистке? 

        End With
    Set emailItem = Nothing
    End If
Next cell

cleanup:
Set emailApplication = Nothing
Application.ScreenUpdating = True
End Sub

1 Ответ

1 голос
/ 20 марта 2020

For Each cell In Worksheets("owssvr").Columns("S").Cells

Сюда входят все пустые ячейки в столбце S, которые не должны превышать l oop.

Найти последнюю строку: 

With Sheets("owssvr") 
    LastRow = .Range("S" & .Rows.Count).End(xlUp).Row 
End With

А теперь l oop только над необходимыми клетками (при необходимости измените S2): 

For Each cell In Worksheets("owssvr").Range("S2:S" & LastRow)
...