Tabelle nach World Transferiere aber mit Format

Sub GanzeTabelleTransferieren()
'Dimensionierung der Variablen
Dim objWordApp As Object
Dim objWordDok As Object
Dim varRange As Variant
Dim objSheet As Object
Dim intCount1 As Integer
Dim intCount2 As Integer
'Auslesen der gesamten Tabelle
varRange = ActiveSheet.UsedRange
'Festlegen der Vorgabewerte
Set objWordApp = CreateObject("Word.application")
'Starten der Word-Instanz und eine neues Dokument öffnen
objWordApp.Visible = True
Set objWordDok = objWordApp.documents.Add
'Anschrift in das Dokument eintragen
With objWordApp.Selection
.TypeText Text:="Daten aus Excel "
.TypeParagraph
.TypeText Text:="Arbeitsmappe: " & ActiveWorkbook.Name
.TypeParagraph
.TypeText Text:="Blatt: " & ActiveSheet.Name
.TypeParagraph
.TypeText Text:="Datum: " & Format(Now(), "dd.mm.yyyy")
.TypeParagraph
.TypeParagraph
.TypeParagraph
End With
'Tabelle im Worddokument einfügen
Set objSheet = objWordDok.Tables.Add _
(objWordApp.Selection.Range, UBound(varRange, 1), UBound(varRange,2))
'Tabelle in Worddokument einfügen
With objSheet
For intCount1 = 1 To UBound(varRange, 1)
For intCount2 = 1 To UBound(varRange, 2)
.cell(intCount1, intCount2).Range.insertafter _
varRange(intCount1, intCount2)
Next intCount2
Next intCount1
End With
'Aufheben der Verbindung zu den Objektvariablen
Set objWordApp = Nothing
Set objworddoc = Nothing
Set objSheet = Nothing
End 

Sub