Paste range side by side in email body

Question

the code below paste two range in an email body one after the other, how to modify the code so the two range are pasted next to each other rng on the left and rng2 on the right

update: managed to get the range side by side using a table with 1 row and 2 columns as suggested by Tim in the comments, problem now is it is too far apart would like to know how to make the pasted ranges closer to each other

update 2: decided to create a table with 3 rows and 2 columns and copy paste each range into each cell, but still the same problem the cells width are too wide using wordTbl.AllowAutoFit = True does not resize the cell width

UPDATE 3 SOLVED WITH wordTbl.Columns(1).AutoFit

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)
        
        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

Answer 1

the code below solves my problem but still open to someone offering a better solution

nitpicking the code below does not copy the interior color format of the copied cell

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)
        
        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
        
        wordTbl.Columns(1).AutoFit
        wordTbl.Columns(2).AutoFit

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