Question

我一直无法运行此代码，其想法是它会获取C列中的每封电子邮件，并在文件D1中附加文件路径。然而，它不断出现错误

“运行时错误91 - 对象变量或未设置块变量”。

我尝试从https://www.rondebruin.nl/win/s1/outlook/amail6.htm

复制和修改此代码

Sub Send_WeeklyUpdatePack()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim SourceFile As String
    Dim DestinationFile As String
    Dim strto As String

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

    ThisWorkbook.Sheets("Weekly Update Directory").Range("D1") = ThisWorkbook.Sheets("Automation").Range("D22") 'Picks up correct filepath

    Set sh = Sheets("Weekly Update Directory")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

        'Enter the path/file names in the C:Z column in each row
            Set rng = sh.Cells(cell.Row, 1).Range("D1") 'ERROR HERE

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = strto
                .Subject = "Weekly update pack"
                .Body = "Hi all," & vbNewLine & vbNewLine & "Please find attached the updated weekly pack." & vbNewLine & vbNewLine & "Kind Regards," & vbNewLine & vbNewLine & "VBA Noob"

                '& cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Display  'Or use .Display/.Send
            End With

            Set OutMail = Nothing
        End If

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

我对VBA相对较新（2周），所以非常感谢正确方向的解释/推动

Answer 1

我修改了下面的代码并且它似乎运行了，虽然我不确定为什么所以任何解释导致问题的原因的评论都会被我和未来的读者大大鼓励。

Sub Send_WeeklyUpdatePack()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim SourceFile As String
    Dim DestinationFile As String
    Dim strto As String

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

    ThisWorkbook.Sheets("Weekly Update Directory").Range("D1") = ThisWorkbook.Sheets("Automation").Range("D22")

    Set sh = Sheets("Weekly Update Directory")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

        'Enter the path/file names in the C:Z column in each row
            Set rng = ThisWorkbook.Sheets("Weekly Update Directory").Range("D1")
        'Set rng = ThisWorkbook.sh.Range("D1")

        'If cell.Value Like "?*@?*.?*" And
           'Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = strto
                .Subject = "Weekly update pack"
                .Body = "Hi all," & vbNewLine & vbNewLine & "Please find attached the updated weekly pack." & vbNewLine & vbNewLine & "Kind Regards," & vbNewLine & vbNewLine & "VBA Noob"

                '& cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Display  'Or use .Display/.Send
            End With

            Set OutMail = Nothing
        'End If

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

感谢

发送附件VBA的电子邮件

1 个答案: