宏在工作表代码窗可运行，放入模块报Runtime 1004求修正

报错Runtime error 1004 - 无法应用于所选区域仅在模块中运行宏时出现，核心原因有两点：

1. 在筛选区域的With代码块内执行添加新工作表的操作，干扰了Excel对原工作表筛选区域的上下文引用
2. 代码混用ActiveSheet、Worksheets(1)这类不确定的工作表引用，导致筛选状态管理混乱

以下是具体的代码调整点：

1. 移出With块内的工作表创建操作 #

将创建新工作表的代码移到第一个筛选区域的With块外，避免破坏原筛选区域的上下文。

2. 统一使用变量ws引用目标工作表 #

替换所有零散的ActiveSheet、Worksheets(1)引用，改用提前定义的ws变量，确保操作始终指向目标工作表。

3. 优化筛选操作流程 #

在对指定区域应用筛选前，先彻底关闭目标工作表的所有筛选状态，避免旧筛选残留导致冲突。

4. 修复HTML拼接语法错误 #

修正原代码中多余的</pre>标签，确保邮件正文HTML格式正常。

Sub RdvBledina()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' 根据需要调整工作表名称
    ws.AutoFilterMode = False ' 统一关闭目标工作表的筛选

    Dim newSheet As Worksheet
    ' 提前创建新工作表，避免在With块内操作干扰筛选
    Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newSheet.Name = "Filtered Results"

    ' 定义第一个区域并应用筛选
    With ws.Range("$B$4:$I$44") ' 根据需要调整区域
        .AutoFilter Field:=4, Criteria1:="20105382" ' 根据需要调整字段和条件
        ' 将筛选结果复制到新工作表
        .SpecialCells(xlCellTypeVisible).Copy newSheet.Range("A3")
    End With
    ws.AutoFilterMode = False ' 关闭筛选

    ' 复制带格式的合并标题单元格
    ws.Range("B2").Copy
    newSheet.Range("A1").PasteSpecial xlPasteAll
    newSheet.Range("A1").HorizontalAlignment = xlLeft

    ' 获取新工作表的最后使用行
    Dim lastRow As Long
    lastRow = newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row
    Application.CutCopyMode = False

    ' 复制第二个筛选结果的标题
    ws.Range("K2").Copy
    newSheet.Range("A" & lastRow + 2).PasteSpecial xlPasteAll
    newSheet.Range("A" & lastRow + 2).HorizontalAlignment = xlLeft

    ' 获取标题后的起始行
    Dim startRow As Long
    startRow = lastRow + 3

    ' 定义第二个区域并应用筛选
    With ws.Range("$K$4:$R$44")
        .AutoFilter Field:=4, Criteria1:="20105382"
        ' 将第二个区域的筛选结果复制到标题下方
        .SpecialCells(xlCellTypeVisible).Copy newSheet.Range("A" & startRow)
    End With
    ws.AutoFilterMode = False ' 关闭筛选

    ' 在“Filtered Results”工作表中自动调整列宽
    newSheet.Columns.AutoFit

    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim FilteredSheet As Worksheet

    ' 设置Outlook对象模型引用
    Set OutlookApp = CreateObject("Outlook.Application")
    ' 创建新邮件
    Set OutlookMail = OutlookApp.CreateItem(0)

    ' 设置主题和收件人
    With OutlookMail
        .Subject = "Filtered Results"
        .To = "recipient@example.com" ' 替换为所需的电子邮件地址
        ' 修复HTML标签嵌套错误
        .HTMLBody = "<html><body>" & RangetoHTML(newSheet.UsedRange) & "</body></html>"
    End With

    ' 显示邮件
    OutlookMail.Display

    ' 释放Outlook对象模型资源
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

' 将Excel区域转换为HTML的函数
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"

    ' 复制区域并粘贴到新的临时工作表
    Set TempWB = Workbooks.Add(1)
    rng.Copy
    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

    ' 将临时工作表发布为.htm文件
    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

    ' 将.htm文件读取为字符串
    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=")

    ' 删除临时.htm文件
    Kill TempFile

    ' 删除临时工作表
    TempWB.Close savechanges:=False

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

• 提前创建newSheet，避免在筛选上下文内修改工作簿结构，消除引用干扰
• 全程使用ws变量操作目标工作表，彻底避免ActiveSheet带来的不确定性
• 每次筛选完成后立即关闭目标工作表的筛选状态，防止后续操作冲突
• 修正邮件正文的HTML标签错误，确保内容格式正常

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