求助：修改Email Range VBA代码，筛选特定数据并移除空列

完全可以实现，以下是修改后的完整代码，核心是先对数据做筛选和列保留处理，再生成邮件内容：

Sub email_range()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim tempWs As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    
    ' 设置源工作表（根据你的实际表名修改）
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' 创建临时工作表存放处理后的数据
    Set tempWs = ThisWorkbook.Worksheets.Add
    
    ' 复制需要保留的列：item、description、Buy（假设这三列的表头在第1行）
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For j = 1 To lastCol
        Select Case ws.Cells(1, j).Value
            Case "item", "description", "Buy"
                ws.Columns(j).Copy tempWs.Cells(1, tempWs.Cells(1, tempWs.Columns.Count).End(xlToLeft).Column + 1)
        End Select
    Next j
    
    ' 筛选Buy列值为0或1的行
    lastRow = tempWs.Cells(tempWs.Rows.Count, "C").End(xlUp).Row
    tempWs.Range("A1:C" & lastRow).AutoFilter Field:=3, Criteria1:="0", Operator:=xlOr, Criteria2:="1"
    
    ' 复制筛选后的可见行到临时区域（跳过表头）
    tempWs.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).Copy tempWs.Cells(lastRow + 2, 1)
    ' 清除原筛选区域
    tempWs.Range("A1:C" & lastRow).ClearContents
    ' 移动处理后的数据到表头下方
    lastRow = tempWs.Cells(tempWs.Rows.Count, 1).End(xlUp).Row
    tempWs.Range("A" & lastRow - (lastRow - (lastRow + 2) + 1) + 1 & ":C" & lastRow).Cut tempWs.Range("A2")
    ' 关闭筛选
    tempWs.AutoFilterMode = False
    
    ' 移除空列（处理后如果有列全空的情况）
    lastCol = tempWs.Cells(1, tempWs.Columns.Count).End(xlToLeft).Column
    For j = lastCol To 1 Step -1
        If WorksheetFunction.CountA(tempWs.Columns(j)) = 0 Then
            tempWs.Columns(j).Delete
        End If
    Next j
    
    ' 创建邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = "recipient@example.com" ' 修改为收件人邮箱
        .CC = ""
        .BCC = ""
        .Subject = "筛选后的商品数据"
        .HTMLBody = RangetoHTML(tempWs.UsedRange) ' 使用处理后的区域生成HTML
        .Display ' 可改为.Send直接发送
    End With
    On Error GoTo 0
    
    ' 删除临时工作表
    Application.DisplayAlerts = False
    tempWs.Delete
    Application.DisplayAlerts = True
    
    Set OutMail = Nothing
    Set OutApp = 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
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

关键修改说明： #

1. 创建临时工作表：避免修改原数据，所有筛选和列保留操作在临时表中完成
2. 保留指定列：遍历源表表头，仅复制item、description、Buy三列到临时表
3. 筛选目标行：使用AutoFilter筛选Buy列值为0或1的行，提取可见行数据
4. 移除空列：反向遍历临时表列，删除全为空的列
5. 生成邮件：将处理后的临时表区域通过RangetoHTML转换为邮件正文

注意：需要根据你的实际工作表名称修改代码中Set ws = ThisWorkbook.Worksheets("Sheet1")的表名，以及收件人邮箱地址。

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