Word til excel

Jeg har følgende macrocode, men den stopper i den array jeg har oprettet, hvor den skal hente teksten fra dokumentet.

Data = .Range(.Range(1), .Range(1 & .Range(10000).End(xlUp).Row))

Peger på fejl ved ".end"

Jeg vil gerne have den henter over i et array, da der kan være meget tekst der skal flyttes.

Det virker fint, men langsomt med:
With wrdDoc
        .Range.Copy
        ToSheet.PasteSpecial xlPasteValues
End With

Hele koden:

Private Sub CbProject2_Change()
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim rTarget As Long
    Dim Data As Variant
    Dim ToSheet As Worksheet
   
    '******************************
    Set ToSheet = ThisWorkbook.Worksheets("Projekt tekst 2")
    '******************************
   
    Application.ScreenUpdating = False
   
    If Ark1.CbProject2.Value = False Then
    ToSheet.Range("A1:A1000").EntireRow.Delete
    Exit Sub
    ElseIf Ark1.CbProject2.Value = True Then
    '******************************
    Set wrdApp = CreateObject("Word.Application")
    Set wrdDoc = wrdApp.Documents.Open("C:\Test mappe\Projekt tekst 2.doc")
    '******************************

'Get data
    rTarget = ToSheet.Range("A65000").End(xlUp).Row + 1
    With wrdDoc
        Data = .Range(.Range(1), .Range(1 & .Range(10000).End(xlUp).Row))           
        ToSheet.Cells(rTarget, "A").Resize(UBound(Data, 1), UBound(Data, 2)) = Data 
    End With
    wrdApp.Quit         
    Set ToSheet = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    'ActiveWorkbook.Saved = True
End If
Application.ScreenUpdating = True
End Sub