如何调用引用 SpecialCells 的子程序？

Question

我构建了一个脚本来创建发送给不同人的电子邮件，其中包含单独的附件。 我有从这个母脚本调用的不同子例程。

在调用子程序 Distribution 之前它一直有效。 它停在

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

Sub 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 的网站上拿来的。

错误是：

所选单元格中没有数据。

如果我停止母脚本并独立运行此子例程，则不会出现任何问题。

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

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

如何调用引用 SpecialCells 的子程序？

问题描述

1 个解决方案

解决方案1
2 已采纳 2021-01-27 14:52:19

如何调用引用 SpecialCells 的子程序？

问题描述

1 个解决方案

解决方案1 2 已采纳 2021-01-27 14:52:19

解决方案1
2 已采纳 2021-01-27 14:52:19