如何調用引用 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