VBA代码实现复制指定区域时跳过空白单元格并粘贴至邮件

问题背景 #

现有VBA代码可将指定单元格区域粘贴至邮件，但需求改为仅复制含数据的单元格，跳过空白单元格。目标区域C12:J29由外部数据源填充，空白位置不固定；使用xlCellTypeConstants仅能复制无公式的行，无法处理含公式的空白单元格，需通过判断单元格内容长度筛选有效数据。

修改后代码 #

Sub PrepareMailOffer()
    Dim rng As Range
    Dim cell As Range
    Dim hiddenCells As Collection
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("000000").Range("C12:J29")
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "所选不是有效区域或工作表受保护，请修正后重试。", vbOKOnly
        Exit Sub
    End If

    ' 初始化集合存储被隐藏的单元格，用于后续恢复
    Set hiddenCells = New Collection
    ' 遍历区域，隐藏空白单元格
    For Each cell In rng
        If Len(Trim(cell.Value)) < 1 Then
            cell.EntireRow.Hidden = True
            hiddenCells.Add cell
        End If
    Next cell

    ' 取可见单元格（即非空白）
    Set rng = rng.SpecialCells(xlCellTypeVisible)
    If rng Is Nothing Then
        MsgBox "区域内无有效数据。", vbOKOnly
        ' 恢复隐藏单元格
        For Each cell In hiddenCells
            cell.EntireRow.Hidden = False
        Next cell
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

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

    On Error Resume Next
    With OutMail
        .To = Range("N4").Value
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    ' 恢复之前隐藏的单元格
    For Each cell In hiddenCells
        cell.EntireRow.Hidden = False
    Next cell

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

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set hiddenCells = Nothing
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    '复制区域并新建工作簿粘贴数据
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 ' 复制列宽
        .Cells(1).PasteSpecial xlPasteValues, , False, False ' 粘贴值
        .Cells(1).PasteSpecial xlPasteFormats, , False, False ' 粘贴格式
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    '发布工作表为HTML文件
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    '读取HTML内容
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    '关闭临时工作簿
    TempWB.Close savechanges:=False

    '删除临时HTML文件
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

关键修改说明 #

1. 空白单元格筛选逻辑：遍历目标区域，通过Len(Trim(cell.Value)) < 1判断空白单元格，隐藏对应行并记录到集合中
2. 恢复原工作表状态：邮件生成完成后，遍历集合恢复所有被隐藏的行，避免修改原工作表的显示状态
3. 兼容含公式的单元格：通过判断单元格实际值的长度，既过滤了空值公式单元格，也保留了有数据的公式单元格

内容的提问来源于stack exchange，提问作者kyle245