Excel宏开发求助：I列值为Y时复制3行并处理日期及Outlook邀请

需求说明 #

• 当当前工作表（模块中使用Worksheet("data")）的I列单元格输入值为“Y”时，触发以下操作：
  1. 复制该行A:H列区域，在原行上方插入3次该内容，新插入行的I列留空
  2. 修改新插入行的A列日期：
     • 第1行新插入行A列 = 原始日期 - 7个工作日（不含周末）
     • 第2行新插入行A列 = 原始日期 - 14个工作日（不含周末）
     • 第3行新插入行A列 = 原始日期 - 21个工作日（不含周末）
  3. 弹出消息框询问“是否继续创建Outlook日历邀请”，选择“Y”则执行创建日历邀请的宏，选择“N”则终止程序

现有代码问题 #

原代码仅实现了插入空行的逻辑，未完成复制内容、日期修改、Outlook交互等核心需求，且未对触发范围做限定，容易引发不必要的对象错误，也无法推进到Outlook相关步骤。

修正后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim originalRow As Long
    Dim originalDate As Date
    Dim i As Integer
    
    ' 限定触发范围：仅当I列单个单元格输入"Y"时执行
    If Target.Column <> 9 Or Target.Cells.Count > 1 Or UCase(Target.Value) <> "Y" Then Exit Sub
    
    ' 定义工作表，模块中替换为Set ws = ThisWorkbook.Worksheets("data")
    Set ws = Me
    originalRow = Target.Row
    originalDate = ws.Cells(originalRow, "A").Value
    
    ' 关闭事件触发与屏幕更新，避免循环和闪烁
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    On Error GoTo Cleanup ' 错误处理，确保事件和屏幕更新恢复
    
    ' 复制原行A:H列内容
    ws.Range("A" & originalRow & ":H" & originalRow).Copy
    
    ' 插入3行并粘贴内容
    For i = 1 To 3
        ws.Rows(originalRow).Insert Shift:=xlDown
        ws.Range("A" & originalRow & ":H" & originalRow).PasteSpecial xlPasteAll
        ' 清空新行I列
        ws.Cells(originalRow, "I").ClearContents
    Next i
    
    ' 修改新插入行的A列日期
    ws.Cells(originalRow, "A").Value = WorksheetFunction.WorkDay(originalDate, -7)
    ws.Cells(originalRow + 1, "A").Value = WorksheetFunction.WorkDay(originalDate, -14)
    ws.Cells(originalRow + 2, "A").Value = WorksheetFunction.WorkDay(originalDate, -21)
    
    ' Outlook邀请确认弹窗
    If MsgBox("是否继续创建Outlook日历邀请", vbYesNo + vbQuestion, "确认操作") = vbYes Then
        ' 调用你的Outlook日历邀请宏，替换为实际宏名称
        CreateOutlookInvite
    End If

Cleanup:
    ' 恢复事件与屏幕更新
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.CutCopyMode = False ' 清除复制状态
    Set ws = Nothing
End Sub

' 示例Outlook日历邀请宏（根据实际需求修改）
Sub CreateOutlookInvite()
    Dim olApp As Object
    Dim olMeeting As Object
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then Set olApp = CreateObject("Outlook.Application")
    
    Set olMeeting = olApp.CreateItem(1) ' 1代表会议邀请
    With olMeeting
        .Subject = "会议邀请" ' 替换为实际主题
        .Start = Now() ' 替换为实际开始时间
        .Duration = 60 ' 会议时长（分钟）
        .Location = "会议室" ' 替换为实际地点
        .Recipients.Add("example@domain.com") ' 替换为参会人邮箱
        .Body = "会议内容说明" ' 替换为实际内容
        .Display ' 显示邀请窗口，若需直接发送改为.Send
    End With
    
    Set olMeeting = Nothing
    Set olApp = Nothing
End Sub

代码关键说明 #

• 触发范围限定：仅当I列单个单元格输入“Y”时执行，避免无关操作触发宏
• 事件与屏幕控制：关闭EnableEvents防止插入行时重复触发Worksheet_Change，关闭ScreenUpdating提升运行效率
• 日期计算：使用WorksheetFunction.WorkDay自动排除周末，计算指定工作日偏移后的日期
• 错误处理：通过On Error GoTo Cleanup确保无论是否出错，都能恢复事件和屏幕更新状态
• Outlook交互：通过MsgBox获取用户选择，调用自定义的日历邀请宏，示例宏包含基础的会议邀请创建逻辑，可根据需求修改

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