如何将Excel指定区域数据写入OLAppointment.Body？

核心实现思路 #

要把Worksheets("Manager County Info").Range("D7:I17")的内容导入Outlook约会正文，只需逐行读取区域内的单元格数据：每行内的单元格用制表符（vbTab）分隔保证排版整齐，行与行之间用换行符（vbNewLine）分隔，最后将拼接好的字符串赋值给OLAppointment.Body即可。

修改后的完整代码 #

Sub Appointments()
Const olAppointmentItem As Long = 1
Dim olApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim bodyText As String
Dim rng As Range
Dim row As Range
Dim cell As Range

Call GetData

' 保留原有目标区域赋值逻辑
Worksheets("Manager County Info").Range("D7").Value = Worksheets("Loans").Range("I" & ActiveCell.Row).Value

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0

If Not olApp Is Nothing Then
    Set OLNS = olApp.GetNamespace("MAPI")
    OLNS.Logon

    Set OLAppointment = olApp.CreateItem(olAppointmentItem)
    OLAppointment.Subject = Worksheets("Loans").Range("B" & ActiveCell.Row).Value & " (LGI Builder LO - " & Worksheets("Loans").Range("K" & ActiveCell.Row).Value & ")" _
    & " COE " & Worksheets("Loans").Range("W" & ActiveCell.Row).Value & " (" & Worksheets("Loans").Range("Q" & ActiveCell.Row).Value & ")"
    OLAppointment.Start = Worksheets("Loans").Range("M" & ActiveCell.Row).Value & " " & Format(Worksheets("Loans").Range("O" & ActiveCell.Row).Value, "h:mm")
    
    ' 读取指定区域并拼接正文内容
    Set rng = Worksheets("Manager County Info").Range("D7:I17")
    bodyText = ""
    For Each row In rng.Rows
        For Each cell In row.Cells
            ' 单元格内容用制表符分隔，空单元格保留占位
            bodyText = bodyText & cell.Value & vbTab
        Next cell
        ' 移除每行末尾多余制表符后添加换行
        bodyText = Left(bodyText, Len(bodyText) - Len(vbTab)) & vbNewLine
    Next row
    
    ' 赋值给约会正文
    OLAppointment.Body = bodyText
        
    OLAppointment.Location = "Borrower Cell"
    OLAppointment.Duration = 90
    OLAppointment.ReminderMinutesBeforeStart = 180
    OLAppointment.Display

    ' 释放对象
    Set OLAppointment = Nothing
    Set OLNS = Nothing
    Set olApp = Nothing
    Set rng = Nothing
End If
End Sub

关键修改说明 #

1. 移除冗余代码：删除了原代码中formattedHTHLL、formattedBond2LL等格式化变量——所有需要的内容已提前整理到目标区域，无需单独处理。
2. 区域内容拼接逻辑：
   • 用rng对象指向目标区域D7:I17
   • 嵌套循环遍历每一行和每个单元格，用vbTab保证列对齐
   • 每行结束后清理末尾多余制表符，再添加换行符
3. 直接赋值正文：将拼接好的bodyText直接赋值给OLAppointment.Body，替代原有的手动拼接逻辑。

可选优化（忽略空行） #

如果要跳过区域内的空行，可以在循环内添加判断：

For Each row In rng.Rows
    ' 仅处理非空行
    If WorksheetFunction.CountA(row) > 0 Then
        For Each cell In row.Cells
            bodyText = bodyText & cell.Value & vbTab
        Next cell
        bodyText = Left(bodyText, Len(bodyText) - Len(vbTab)) & vbNewLine
    End If
Next row

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