Question

此脚本正常工作，直到我只有一行，后面没有行。它正在经历并选择A：D列并停在下一个空白行。

这非常有效，直到它获得一行是一行，后面有一个空白行。当它碰到其中一个时它也会因为某种原因选择下一个部分的第一行。

我确信这与我把它放在一起的半危险方式有关。任何帮助表示赞赏

以下是代码：

Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim N As Long
Dim emailRng As Range, cl As Range
Dim sTo As String
Dim StrBody As String
Dim StrBody2 As String
Dim intCol As Integer

Do Until IsEmpty(ActiveCell.Value)
    ActiveCell.Value = ActiveCell.Value
    ActiveCell.Offset(0, 0).Select

StrBody = "Greetings" & "<br>" & _
          "" & "<br>" & _
          "We are conducting our quarterly access appropriateness audit, as required by SOX. We are required to do a quarterly audit of the associates who have access to the application to verify if the access should be marked as retain or remove. The following associate(s) have access to the SSD application. Please reply to this email, stating whether the below associate(s) should be marked to RETAIN or REMOVE the access." & "<br><br><br>"

StrBody2 = "<font color=""red"" >" & "<br>" & "<b>If no response is received, the access will be removed from the associate(s)</b><br></font>" & _
"<font color=""red"" >" & "<b>***Please reply by end of day Tuesday, 21 2015 ***</b></font><br><br><br>"

StrBody3 = "Thank You" & "<br>" & "Transition Audit" & "<bz><bz><bz>"

Set emailRng = Worksheets("Sheet1").Range("E2:E3")

For Each cl In emailRng
    sTo = sTo & ";" & cl.Value
Next

sTo = Mid(sTo, 2)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

N = Cells(2, 1).End(xlDown).Row
Range("A1:D" & N).Select

Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
           vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .SentOnBehalfOfName = "Transition Audits"
    .To = sTo
    .CC = ""
    .BCC = ""
    .Subject = "2015 Q3 UA-2 SSD, Response Required: SSD (Sales and Service Delivery) SOX Appropriate Access Audit"
    .HTMLBody = StrBody & RangetoHTML(rng) & StrBody2 & StrBody3
    .Send   'or use .Display
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
rng.Resize(, rng.Columns.Count + 1).Select
Selection.Offset(1, 0).Select
Selection.Clear
    DeleteBlankRows
 Loop
End Sub

以下是可能出现此问题的工作表示例。

Emp ID Name Mgr Email

123413 Test4 test@email.com 123413测试5
123413 Test6

123413 Test7 test@email.com

123413 Test8 test@email.com 123413测试9
123413测试10
123413测试11
123413试验12
123413测试13
123413 Test14
123413 Test15

第一个块可以正常工作并将行删除到单行。当它突出显示该行时，它也会突出显示以Test8开头的行

Answer 1

我设法很简单地修复它

这条线 N =单元格（2,1）.End（xlDown）.Row

需要 N =单元格（1,1）.End（xlDown）.Row

因为我每次都包含标题，无论如何它都是完美的。

此脚本仅在单行之后获取额外的行

1 个答案: