Daten aus Word-Tabellen in Excel überführen

  • Excel

Es gibt 4 Antworten in diesem Thema. Der letzte Beitrag () ist von Marco123.

    Daten aus Word-Tabellen in Excel überführen

    Hallo Forum,
    aktuell bin ich damit zugange anhand der in diversen Betriebsanweisungen vorhandenen Daten (eine Word-Datei pro Thema, Daten in vorgegebener Tabellenform) eine sich selbstständig aktualisierende Excel-Tabelle zu erstellen. Das Ganze soll durch die Zusammenfassung aller Daten viel übersichtlicher werden.

    Das Auslesen der Word-Tabellen als auch das Einfügen in die Excel-Datei funktioniert mit folgendem Code schonmal ganz gut:

    Visual Basic-Quellcode

    1. Sub Word_Tabellen_auslesen()
    2. Dim cL As Object
    3. Dim sPfad As String
    4. Dim appWord As Object
    5. Dim i As Long
    6. Dim a As Long
    7. Dim counter As Long
    8. Dim cDir As String
    9. Dim ws As Excel.Worksheet
    10. counter = 1
    11. On Error GoTo ENDE
    12. 'Aktualisierung ausschalten
    13. With Application
    14. .ScreenUpdating = False
    15. .Calculation = xlCalculationManual
    16. .EnableEvents = False
    17. End With
    18. 'WordObject erstellen
    19. Set appWord = CreateObject("Word.Application")
    20. 'Zielblatt
    21. Set ws = Tabelle002
    22. 'Bereich festlegen
    23. Set isect = Application.Intersect(ws.UsedRange, ws.Range("B3:D" & Rows.Count))
    24. 'Pfad
    25. sPfad = "C:\Users\Marco123\Desktop\Projekt\"
    26. cDir = Dir(sPfad & "*.doc")
    27. 'Tabelle vorher leeren
    28. isect.ClearContents
    29. Do While cDir <> ""
    30. 'Worddocument ?ffnen
    31. appWord.Documents.Open sPfad & cDir, ReadOnly:=True
    33. 'Wordtabelle auslesen
    34. 'Zeilen
    35. For a = 1 To 15
    36. i = 0
    37. 'Spalten
    38. For Each cL In appWord.activeDocument.Tables(1).Rows(a).Cells
    39. i = i + 1
    40. ws.Cells(a + counter, i) = Left(cL.Range.Text, Len(cL.Range.Text) - 2)
    41. Next
    42. Next a
    44. 'n?chstes Document lesen
    45. cDir = Dir
    46. counter = counter + 15
    48. 'Worddocument schliessen
    49. appWord.activeDocument.Close savechanges:=False
    51. Loop
    52. ENDE:
    53. 'WordObject l?schen
    54. Set appWord = Nothing
    56. 'gef?llte Zellen an Inhalt anpassen
    57. isect.VerticalAlignment = xlTop
    58. isect.WrapText = True
    59. isect.ColumnWidth = 50
    60. isect.EntireRow.AutoFit
    62. 'Aktualisierung einschalten
    63. With Application
    64. .ScreenUpdating = True
    65. .Calculation = xlCalculationAutomatic
    66. .EnableEvents = True
    67. End With
    68. End Sub


    Soweit klappt alles.Einziger Downer ist der Umstand, das die Textinhalte der einzelnen Word-Tabellenzellen ohne die dort vorhandenen Umbrüche/Absätze sondern als ein langer Strang in die einzelnen Excel-Zellen geschrieben werden.Wenn man jedoch die dann befüllten Zellen per Doppelklick oder F2 anwählen, passt sich der Inhalt automatische wieder an.
    Kennt einer von Euch dieses Problem und hat evtl. den passenden Tipp oder gar eine Lösung parat?

    Vielen Dank im Voraus für Eure Unterstützung

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Marco123“ ()

    Sind denn die Zellen im Excel-Blatt alle so formatiert, dass sie auch Textumbrüche können?

    Ansonsten - das Thema hatte ich hier letztens an anderer Stelle - gibt es häufig auch Formatierungsoptionen. Unter Umständen mal schauen, ob es sowas auch gibt, denn dann sind dort Umbrüche extra formatieren.

    Hi Padre,

    die Zellformatierung wird bereits in den Zeilen 57 bis 60 des Codes angepasst. Zeile 58 schaltet den Textumbruch.
    Der Inhalt wird daher schon an die Zellgröße angepasst (Textumbruch, Ausrichtung), was das Problem aber nicht löst.
    Die Umbrüche / Absätze erscheinen weiterhin erst wenn die Zellen manuell per Doppelklick / F2 angewählt werden.

    Auch die manuelle Anpassung der Zellformatierung schafft keine Abhilfe.

    Ursache des ganzen scheint die Code-Zeile 40 zu sein:

    Visual Basic-Quellcode

    1. ws.Cells(a + counter, i) = Left(cL.Range.Text, Len(cL.Range.Text) - 2)


    Die Kombi Left + Len bewirkt ja, das von links an die Anzahl der Zeichen aufgenommen wird, welche übernommen werden sollen
    Da Absätze aber keine Zeichen sind, werden diese nicht erfasst.

    Im Gegensatz zur Zelle wird der Inhalt in der Bearbeitungsleiste aber korrekt angezeigt.

    Ich bin weiterhin aktiv auf der Suche nach einer passenden Lösung / Alternative, bin bisher aber nicht fündig geworden.

    Falls jemand etwas parat haben sollte, würde ich mich sehr über eine entsprechende Info freuen.

    Moin Forum,

    kleines Update.
    Ich hab einen Lösungsweg gefunden, auch wenn dieser mal wieder eher dem Vorgehen "von hinten durch dir Brust ins Auge" zuzurechnen ist.

    Hier stichpunktartig mein Vorgehen:
    - Word-Datei per Excel-Makro öffnen
    - in Word-Datei nach Absätzen suchen und durch unübliche Zeichenfolge ersetzen
    - Texte in Excel übernehmen
    - Ersatzzeichen gegen Absätze austauschen (eigenes Makro)

    Der aktuelle Code sieht dann wie folgt aus:

    Visual Basic-Quellcode

    1. Option Explicit
    2. Dim cL As Object
    3. Dim sPfad As String
    4. Dim appWord As Object
    5. Dim objDoc As Object
    6. Dim i As Long
    7. Dim a As Long
    8. Dim counter As Long
    9. Dim cDir As String
    10. Dim ws As Excel.Worksheet
    11. Dim isect
    12. Const Ersatz As String = "<>"
    13. Const wdReplaceAll As Long = 2
    14. Const wdFindContinue As Long = 1
    15. Const wdDoNotSaveChanges As Long = 0
    17. Sub BA_LZ_techn_Einrichtungen_auslesen()
    18. counter = 1
    19. On Error Resume Next
    20. 'Aktualisierung ausschalten
    21. With Application
    22. .ScreenUpdating = False
    23. .Calculation = xlCalculationManual
    24. .EnableEvents = False
    25. End With
    26. 'Zielblatt
    27. Set ws = Tabelle002
    28. 'Bereich festlegen
    29. Set isect = Application.Intersect(ws.UsedRange, ws.Range("B3:D" & Rows.Count))
    30. 'Pfad
    31. sPfad = Tabelle020.Range("D10")
    32. cDir = Dir(sPfad & "*.doc")
    33. 'Tabelle vorher leeren
    34. isect.ClearContents
    35. Do While cDir <> ""
    37. 'WordObject erstellen und ?ffnen
    38. Set appWord = CreateObject("Word.Application")
    39. Set objDoc = appWord.documents.Open(sPfad & cDir, ReadOnly:=True)
    41. 'in Word suchen und ersetzen
    42. appWord.ScreenUpdating = False
    44. With objDoc.Content.Find
    45. .Text = "^p"
    46. .Replacement.Text = Ersatz
    47. .Wrap = wdFindContinue
    48. .Execute Replace:=wdReplaceAll
    49. End With
    51. 'Wordtabelle auslesen
    52. 'Zeilen
    53. For a = 1 To 15
    54. i = 0
    55. 'Spalten
    56. For Each cL In appWord.activeDocument.Tables(1).Rows(a).Cells
    57. i = i + 1
    58. ws.Cells(a + counter, i) = Left(cL.Range.Text, Len(cL.Range.Text) - 2)
    59. Next
    60. Next a
    62. 'Worddocument schliessen
    63. appWord.ScreenUpdating = True
    64. objDoc.Close savechanges:=wdDoNotSaveChanges
    66. 'n?chstes Document lesen
    67. cDir = Dir
    68. counter = counter + 15
    70. Loop
    71. 'WordObject l?schen
    72. Set objDoc = Nothing
    73. appWord.Quit
    74. Set appWord = Nothing
    76. 'gef?llte Zellen an Inhalt anpassen
    77. Absaetze_einfuegen
    78. With isect
    79. .VerticalAlignment = xlTop
    80. .WrapText = True
    81. .ColumnWidth = 50
    82. .EntireRow.AutoFit
    83. End With
    84. ActiveWorkbook.RefreshAll
    86. 'Aktualisierung einschalten
    87. With Application
    88. .ScreenUpdating = True
    89. .Calculation = xlCalculationAutomatic
    90. .EnableEvents = True
    91. End With
    92. End Sub
    94. Sub Absaetze_einfuegen()
    96. ActiveSheet.Cells.Replace What:= Ersatz, _
    97. Replacement:="" & Chr(10), _
    98. LookAt:=xlPart, _
    99. SearchOrder:=xlByRows, _
    100. MatchCase:=False, _
    101. SearchFormat:=False, _
    102. ReplaceFormat:=False, _
    103. FormulaVersion:=xlReplaceFormula2
    105. End Sub


    Das Austauschen in Word verlangsamt die ganze Sache zwar, aber es funktioniert.

    Wenn jemand noch Ideen hat, wie man das ganze noch beschleunigen kann... immer her damit :)

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Marco123“ ()

Facebook
Telefonspende