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

问题描述

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

直到调用子程序 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 = "[email protected]"
                .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列没有数据，但是我运行的时候居然找到了信息？

我认为可以通过激活包含该行之前的脚本的工作簿来修复它，但到目前为止没有成功。

解决方法

使用 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