子程序在调用时不起作用，仅在独立执行时起作用

Question

我构建了一个脚本，旨在创建发送给不同人的电子邮件，其中包含单独的附件。我有从这个母脚本调用的不同子程序。一切都很完美。

直到调用子例程 Distribution。它停在粗体代码行：

'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 StrBody As String
    
    StrBody = "<BODY style=font-size:11pt;font-family:Arial>Hi team," & "<br><br>" & _
              "Please find attached the most updated version of the Weekly Report. " & "<br>" & _
              "If you have any doubt or comment, do not hesitate to reach out to us." & "<br><br>" & _
              "Jorge Martinez"
                
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    Windows("Free Trade Zone Weekly Reports.xlsm").Activate

    **For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)**

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

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

            With OutMail
                .to = cell.Value
                .CC = "tulio.paz@diageo.com"
                .Subject = "Weekly Report " & Date
                Bodyformat = 2
                '.Body = "<BODY style=font-size:11pt;font-family:Arial>Hi team," & "<br><br>" & _
              "Please find attached the most updated version of the Weekly Report " & "<br>" & _
              "If you have any doubt or comment, do not hesitate to reach out to us." & "<br><br>" & cell.Offset(0, -1).Value
                .Importance = 2
                   .HTMLBody = StrBody & 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
            End With

            Set OutMail = Nothing
        End If
    Next cell

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

如您所见，我是从 Ron DeBruin 的网站上获取的，这对我帮助很大。脚本抛出的错误是：所选单元格中没有数据。这不准确，因为里面有数据。

如果我单独停止母脚本和运行这个子例程，它不会出现任何类型的问题。我的问题是，为什么会这样？为什么它说B列没有数据，但是我运行它居然找到了信息？

我认为可以通过激活包含该行之前的脚本的工作簿来解决这个问题，但到目前为止没有成功。

Answer 1

使用 SpecialCells 时，您必须非常小心。试试这个

替换

For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

与

Dim rng As Range

On Error Resume Next
Set rng = sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "No Range with constants were found"
    Exit Sub
End If

For Each cell In rng

子程序在调用时不起作用，仅在独立执行时起作用

Subroutine not working when called, only when executed independently

excel

vba

outlook-addin

sap-gui