Fra indlejret excel tabel i wordfil til ny excelfil?

Du er velkommen til at sende / uploade filen eller model af tilsvarende. @-adresse under min profil så vil jeg prøve om VBA kan gøre noget ved det..

Jeg har sendt dig en email.

Det er pænt af dig.

Vh. Kresten

Rem Version 3
Rem Tools / Reference / Microsoft Excel ??.0 Object Library (flueben)          '<---- OBS
Rem =================================================================
Dim sti As String
Dim xlsFakt As Object
Dim antalSH As Integer, sh As Integer, faktNr As String
Sub konverterTilExcel()
On Error GoTo fejl
    Application.ScreenUpdating = False
   
    Set xlsFakt = CreateObject("Excel.Application")
    sti = ActiveDocument.Path
   
    xlsFakt.Workbooks.Open sti & "\Faktura_Excel.xlsx"
    xlsFakt.Visible = False
   
    ActiveDocument.Activate
    antalSH = ActiveDocument.InlineShapes.Count
   
    If antalSH > 0 Then
        For sh = 1 To antalSH
            With ActiveDocument
                .InlineShapes(1).OLEFormat.Activate
                Selection.Copy
               
                With xlsFakt.ActiveWorkbook.Sheets(1)
                    .Application.ScreenUpdating = False

                    .Cells(1, 1).Activate
                    .Paste
                End With
            End With
            xlsFakt.Visible = False 'True
           
            ActiveSheet.OLEObjects("Object 1").Activate
           
Rem vent          faktNr = ActiveSheet.Range("I6")
           
            ChDir sti
            ActiveWorkbook.SaveAs FileName:= _
                sti & "\Regneark i Faktura_Excel" & "_" & CStr(sh) & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            Selection.Delete
        Next sh
    End If
   
Rem skal også gemmes
    xlsFakt.ActiveWorkbook.Saved = True
    xlsFakt.Application.Quit
    Set xlsFakt = Nothing
    MsgBox "Konvertering udført"
    Exit Sub
   
fejl:
    Stop
    Resume Next
End Sub
Private Sub Document_Open()
Dim svar
    svar = InputBox("Udfør konvertering=Ja", "Dokument-behandling", "Nej")
    If LCase(svar) = "nej" Then
        Exit Sub
    Else
        konverterTilExcel
    End If
End Sub