Dim sFileName As String
Dim iLastRow As Long, i As Long
iLastRow = Cells(1, Columns.Count).End(xlToLeft).Column
sFileName = Cells(1, 1)
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")
WordApp.Documents.Add
WordApp.Documents(1).Tables.Add Range:=WordApp.Selection.Range, NumRows:=2, NumColumns:=iLastRow
WordApp.Selection.Font.Bold = True
WordApp.Visible = True

For i = 1 To 2
For j = 1 To iLastRow

With WordApp

.Documents(1).Tables(1).Cell(i, j).Range.Text = Cells(i, j)
.Documents(1).Tables(1).Cell(i, j).Range.Text = Cells(i, j)

End With

Set WordApp = Nothing
Set doc = Nothing
Next
Next

WordApp.ActiveDocument.SaveAs Filename:=sFileName & ".doc"
End Sub