如何在SendMail宏中实现基于日历周的动态选择以发送团队预测邮件

看起来你需要让每周五发送的预测邮件自动匹配下周的日历周，不用手动调整单元格范围对吧？我帮你修改了原代码，加入了动态周数计算和范围匹配的功能，具体如下：

关键改进点 #

• 自动计算下周的日历周（周五运行时自动指向当前周的下一周）
• 根据周数动态匹配工作表中对应的列范围（适配表头带周数标识的场景）
• 邮件主题和正文自动带上周数，避免混淆
• 增加了错误处理，比如找不到对应周的列时给出提示

修改后的完整代码 #

Sub SendWeeklyForecastMail()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim targetWeekNum As Integer
    Dim weekColStart As Integer, weekColEnd As Integer
    Dim ws As Worksheet
    Dim headerCell As Range
    
    ' 设置目标工作表
    Set ws = ThisWorkbook.Sheets("Availability List")
    
    ' 计算下周的日历周：用参数2确保周一为一周第一天，周五运行时自动+1
    targetWeekNum = WorksheetFunction.WeekNum(Date, 2) + 1
    ' 处理年末边界情况：如果当前是全年最后一周，下周回到第1周
    If targetWeekNum > WorksheetFunction.WeekNum(DateSerial(Year(Date), 12, 31), 2) Then
        targetWeekNum = 1
    End If
    
    ' 查找对应周数的表头列（假设表头格式为"W1", "W2"...，可根据实际修改）
    On Error Resume Next
    Set headerCell = ws.Rows(1).Find(What:="W" & targetWeekNum, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0
    
    If headerCell Is Nothing Then
        MsgBox "未找到对应周数（W" & targetWeekNum & "）的列，请检查表头格式！", vbExclamation
        Exit Sub
    End If
    
    ' 确定要复制的列范围：假设每周占7列（周一到周日），可按需调整列数
    weekColStart = headerCell.Column
    weekColEnd = weekColStart + 6 ' 7列范围，改成+4就是5列，以此类推
    
    ' 选择可见单元格：固定的A1:C7 + 动态匹配的周列范围
    On Error Resume Next
    Set rng = Union(ws.Range("A1:C7"), ws.Range(ws.Cells(1, weekColStart), ws.Cells(7, weekColEnd))).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "没有可见的单元格可以复制，请检查筛选设置！", vbExclamation
        Exit Sub
    End If
    
    ' 创建并配置邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = "收件人邮箱地址" ' 替换为实际收件人
        .CC = "抄送人邮箱地址" ' 按需添加
        .Subject = "团队可用性预测 - 第" & targetWeekNum & "周"
        .HTMLBody = "<p>您好，以下是团队第" & targetWeekNum & "周的可用性预测：</p>" & _
                    RangetoHTML(rng) & _
                    "<p>请查收，谢谢！</p>"
        .Display ' 测试阶段用Display预览，正式使用改成.Send直接发送
    End With
    On Error GoTo 0
    
    ' 释放对象，避免内存占用
    Set OutMail = Nothing
    Set OutApp = Nothing
    MsgBox "邮件已准备就绪！", vbInformation
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"
    
    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
    
    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
    
    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. 表头适配：如果你的表头不是W1/W2格式，比如是第1周/第2周，把代码中"W" & targetWeekNum改成"第" & targetWeekNum & "周"即可。
2. 列数调整：如果每周的预测不是7列，修改weekColEnd = weekColStart + 6中的数字（比如5列就改成+4）。
3. 测试优先：先保留.Display运行，确认邮件内容和范围正确后，再改成.Send自动发送。
4. 权限提示：第一次运行时Outlook可能会弹出安全提示，需要允许VBA访问邮件客户端。

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