修改VBA代码实现Excel区域在Outlook邮件中并排粘贴并调列宽

需求说明 #

原有VBA代码可将两个Excel区域依次粘贴到Outlook邮件正文，需修改代码使rng区域显示在左侧、rng2区域显示在右侧，实现并排布局。

问题解决迭代过程 #

• 第一次尝试：1行2列表格承载
  采用1行2列的表格实现并排，但出现区域间距过宽的问题，布局不符合预期。
• 第二次尝试：3行2列表格逐个粘贴单元格
  改用3行2列的表格，将两个区域的单元格逐个粘贴到对应表格单元格中，但设置wordTbl.AllowAutoFit = True后，无法缩小列宽，间距问题仍未解决。
• 第三次尝试：单独设置列自动适配
  使用wordTbl.Columns(1).AutoFit（可根据需要对第二列也执行该操作），成功实现列宽自动适配，解决了间距过宽的问题。

最终完整VBA代码 #

Sub sendRange()
Dim sht As Worksheet: Set sht = ThisWorkbook.Worksheets("Sheet1")
Dim lastRow As Long: lastRow = sht.Cells(Rows.Count, "S").End(xlUp).Row
Dim i As Long, x
Dim j As Long: j = 1
Dim k As Long: k = 1
Dim rng As Range, rng2 As Range, rngTable, xCell As Range
Dim doc As Object, wordTbl As Object

For i = 3 To lastRow Step 3
    With CreateObject("outlook.application").CreateItem(0)
        .Display '.Send

        .Body = "There it was" & vbNewLine & vbNewLine
        Set doc = .GetInspector.WordEditor
        Set rngTable = doc.Range
        rngTable.Collapse Direction:=0
        Set wordTbl = doc.Tables.Add(rngTable, 3, 2)
        
        ' 设置列自动适配，解决间距问题
        wordTbl.Columns(1).AutoFit
        wordTbl.Columns(2).AutoFit
        
        Set rng = sht.Range("A" & i & ":A" & i + 2)
        Set rng2 = sht.Range("Q" & i & ":Q" & i + 2)
        
        For Each xCell In rng
                xCell.Copy
                wordTbl.cell(j, 1).Range.PasteExcelTable False, False, False
                j = j + 1
        Next xCell
        
        For Each xCell In rng2
                xCell.Copy
                wordTbl.cell(k, 2).Range.PasteExcelTable False, False, False
                k = k + 1
        Next xCell

        .to = sht.Range("S" & i + 2)
        .Subject = "Here it is"
        Application.CutCopyMode = 0
    End With
Next i
End Sub

注：代码中已添加列自动适配的语句，确保并排布局的间距合理。

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