Пропустить пустые ячейки в диапазоне

Ссылка на непустые строки

Sub ReferenceNonBlankRows()
    
    ' Define constants.
    Const SHEET_NAME As String = "000000"
    Const RANGE_ADDRESS As String = "C12:J29"
    
    ' Reference the main objects.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(SHEET_NAME)
    Dim rg As Range: Set rg = ws.Range(RANGE_ADDRESS)
    
    ' Store the range's number of columns in a variable ('ColumnsCount').
    Dim ColumnsCount As Long: ColumnsCount = rg.Columns.Count
    
    ' Declare additional variables.
    Dim urg As Range, rrg As Range, IsFoundNonBlankRow As Boolean
    
    ' Loop through the rows ('rrg') of the range ('rg')
    ' and combine each non-blank row ('rrg') into a unioned range ('urg').
    For Each rrg In rg.Rows
        ' 'CountBlank' counts the number of blank cells
        ' (cells whose length is 0) in a range.
        If Application.CountBlank(rrg) < ColumnsCount Then
            If IsFoundNonBlankRow Then
                Set urg = Union(urg, rrg)
            Else
                Set urg = rrg
                IsFoundNonBlankRow = True ' never reset
            End If
        End If
    Next rrg
    
    ' Check if all rows are blank.
    If Not IsFoundNonBlankRow Then
        MsgBox "All rows in the range ""'" & ws.Name & "'!" _
            & rg.Address(0, 0) & """ are blank!", vbExclamation
        Exit Sub
    End If
    
    ' Continue using 'urg', e.g.:
    MsgBox "The rows ""'" & ws.Name & "'!" _
        & urg.Address(0, 0) & """ are not blank.", vbInformation
        
End Sub

РЕДАКТИРОВАТЬ

• Вы можете создать функцию, используя приведенную выше идею.

Function RefNonBlankRows( _
    ByVal rg As Range, _
    Optional ByVal ShowFailMessage As Boolean = False) _
As Range
    
    ' Store the range's number of columns in a variable ('ColumnsCount').
    Dim ColumnsCount As Long: ColumnsCount = rg.Columns.Count
    
    ' Declare additional variables.
    Dim urg As Range, rrg As Range, IsFoundNonBlankRow As Boolean
    
    ' Loop through the rows ('rrg') of the range ('rg')
    ' and combine each non-blank row ('rrg') into a unioned range ('urg').
    For Each rrg In rg.Rows
        ' 'CountBlank' counts the number of blank cells
        ' (cells whose length is 0) in a range.
        If Application.CountBlank(rrg) < ColumnsCount Then
            If IsFoundNonBlankRow Then
                Set urg = Union(urg, rrg)
            Else
                Set urg = rrg
                IsFoundNonBlankRow = True ' never reset
            End If
        End If
    Next rrg
    
    ' Check if all rows are blank.
    If Not IsFoundNonBlankRow Then
        If ShowFailMessage Then
            MsgBox "All rows in the range ""'" & rg.Worksheet.Name & "'!" _
                & rg.Address(0, 0) & """ are blank!", vbExclamation
        End If
        Exit Function
    End If
    
    ' Assign non-blank rows to the result of the function.
    Set RefNonBlankRows = urg

End Function

• Тогда вы можете использовать его следующим образом.

Sub PrepareMailOffer()
    
    ' Define constants.
    Const SHEET_NAME As String = "000000"
    Const RANGE_ADDRESS As String = "C12:J29"
    Const EMAIL_CELL_ADDRESS As String = "N4"
    
    ' Reference the main objects.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(SHEET_NAME)
    Dim rg As Range: Set rg = ws.Range(RANGE_ADDRESS)

    ' Reference the non-blank rows.
    Dim nbrg As Range: Set nbrg = RefNonBlankRows(rg, True)
    If nbrg Is Nothing Then Exit Sub

    Dim outApp As Object: Set outApp = CreateObject("Outlook.Application")
    Dim outMail As Object: Set outMail = OutApp.CreateItem(0)
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    On Error Resume Next
        With outMail
            .To = ws.Range(EMAIL_CELL_ADDRESS).Value
            .CC = ""
            .BCC = ""
            .Subject = ""
            .HTMLBody = "" _
                & "" _
                & RangetoHTML(nbrg) _
                & ""
            .Display
        End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Пожалуйста, попробуйте следующий адаптированный код, который скрывает пустые строки (даже с пробелами в формуле) и обрабатывает видимые ячейки результирующего диапазона:

Sub PrepareMailOffer()
    Dim ws As Worksheet, rng As Range, rngH As Range, i As Long
    Dim OutApp As Object, OutMail As Object

    Set ws = Sheets("000000")
    Set rng = ws.Range("C12:J29")

    'place the blank rows in a Union range and hide them, at once:
    For i = 1 To rng.rows.count
       If WorksheetFunction.CountBlank(rng.rows(i)) = rng.Columns.count Then
           addToRange rngH, rng.rows(i).EntireRow
       End If
    Next i
    If Not rngH Is Nothing Then rngH.EntireRow.Hidden = True 'hide the blank rows
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    With OutMail
        .To = Range("N4").Value
        .cc = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = "" & _
            RangetoHTML(rng.SpecialCells(xlCellTypeVisible)) & _
            "" & _
        .Display
    End With
    
    If Not rngH Is Nothing Then rngH.EntireRow.Hidden = False 'unhide the previous hidden rows
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

On Error Resume Next только в контексте вашего кода не сообщайте вам, какая у вас ошибка, если таковая имеется...

Вам следует использовать ту же (существующую) функцию RangetoHTML...

Пожалуйста, оставьте отзыв после тестирования.