markierten Tabelleninhalt exportieren

  • Word

Es gibt 6 Antworten in diesem Thema. Der letzte Beitrag () ist von roddy.

    markierten Tabelleninhalt exportieren

    Hallo,

    ich möchte aus einer Doc-Datei bestimmte markierte Zellen aus einer Tabelle in eine txt-datei exportieren. Danach soll der Text auch noch umformatiert/sortiert werden. Ungefähr so:

    Tabelle in Word (in etwa):

    | Kopf A | Kopf B | Kopf C | Kopf D |
    | Text A | Text B | Text C | Text D |


    Ergebnis in der Textdatei:

    Kopf A
    Text A

    Kopf B
    Text B

    Kopf C
    Text C

    Kopf D
    Text D


    Ich hab schon viel experimentiert aber da ich total neu bei VBA bin ist da nichts vernünftiges bei rausgekommen.
    Könnt ihr mir ein paar Hilfreiche Tips geben, wie man so etwas realisieren kann. Ich wäre euch sehr dankbar.

    soegel

    Was das Arbeiten mit Text-Dateien angeht, empfehle ich dir, in der VB-Hilfe den Eintrag "TextStream-Objekt" und dessen Eigenschaften und Methoden anzusehen. In deinem Beispiel würde sich da die "WriteLine"-Methode anbieten, denke ich.

    Was das Auslesen der Daten in der Tabelle angeht, kannst du dir mal den Hilfe-Eintrag "Table-Objekt" ansehen.

    Hier noch ein Code-Schnipsel, der dir als Inspiration dienen soll:

    Visual Basic-Quellcode

    1. For i = 1 To Selection.Cells.Count
    2. MsgBox Selection.Cells(i)
    3. MsgBox Selection.Cells(i).Column.Index
    4. MsgBox Selection.Cells(i).Row.Index
    5. Next

    Hallo, ich bin jetzt soweit:

    Visual Basic-Quellcode

    1. Sub test()
    2. Dim i As Integer
    3. Dim FileName As String
    5. Dim arrOrdner As Variant
    6. Dim iOrdner As Integer
    7. Dim sDrive As String
    8. Dim sOrdner As String
    9. Dim sTmp As String
    10. Dim FullFilePath As String
    11. Dim ueberschreiben As String
    12. Dim position As Long
    14. sOrdner = InputBox("Wo soll die Datei gespeichert werden. Pfad mit Laufwerksbuchstaben angeben. (zb: C:\Ordner1\Ordner2) (nicht vorhandene Verzeichnisse werden erstellt):")
    15. FileName = InputBox("Namen der Export-Datei angeben. Dateiendung '.ts' wird automatisch angehängt.")
    16. If sOrdner = "" Then Exit Sub
    17. If FileName = "" Then Exit Sub
    19. 'Eventuelles "\" am Ende des eingegebenen Pfades entfernen
    20. If Right(sOrdner, 1) = "\" Then
    21. sOrdner = Left(sOrdner, Len(sOrdner) - 1)
    22. End If
    23. neuername:
    24. 'Check auf Existenz der Datei
    25. FullFilePath = sOrdner & "\" & FileName & ".ts"
    26. If CheckPath(FullFilePath) Then
    27. nochmalfragen:
    28. ueberschreiben = InputBox("Die Datei existiert bereits." & Chr(13) & _
    29. "Überschreiben? j/n")
    31. If ueberschreiben = "n" Then
    32. FileName = InputBox("Anderen Dateinamen angeben. Dateiendung '.ts' wird automatisch angehängt.")
    33. GoTo neuername
    34. ElseIf ueberschreiben = "j" Then
    35. GoTo weitermachen
    36. Else: GoTo nochmalfragen 'falls ungültige Eingabe
    37. End If
    38. Else
    39. weitermachen:
    40. arrOrdner = fncFolders(sOrdner)
    41. For iOrdner = UBound(arrOrdner) To 1 Step -1
    42. If fncIfFolderExists(CStr(arrOrdner(iOrdner))) Then
    43. iOrdner = iOrdner - 1
    44. Else
    45. MkDir arrOrdner(iOrdner)
    46. End If
    47. Next iOrdner
    49. Set fs = CreateObject("Scripting.FileSystemObject")
    50. Set a = fs.CreateTextFile(sOrdner & "\" & FileName & ".ts", True)
    52. 'If Selection.Tables(1).Rows.Count > 1 Then
    53. 'MsgBox ("Bitte nur eine Tabellenzeile markieren!")
    54. 'Exit Sub
    55. 'End If
    58. For i = 1 To Selection.Cells.Count
    60. ' Hier werden die "Überschriften" zugeordnet und Kommentar-Symbole vorgesetzt.
    61. ' Vorraussetzung ist, das die Zelleninhalte ohne Zeilenumbruch eingefügt werden.
    62. If i = 1 Then
    63. a.write ("# - Nummer: ")
    64. ElseIf i = 2 Then
    65. a.write ("# - Stichwort: ")
    66. ElseIf i = 3 Then
    67. a.write ("# - Beschreibung: ")
    68. ElseIf i = 4 Then
    69. a.write ("# - Erwartung: ")
    70. Else
    71. a.write ("# ")
    72. End If
    74. 'Einfügen der Zelleninhalte
    75. a.WriteLine (Left(Selection.Cells(i), 500))
    76. 'position = 500
    77. 'Do While Right(Selection.Cells(i), position) <> ""
    78. 'a.WriteLine (Mid(Selection.Cells(i), position, position + 500))
    79. 'position = position + 500
    80. 'Loop
    83. ' Das Zeichen durch ein Leerzeichen ersetzen
    84. 'With Selection.Find
    85. '.Text = ""
    86. '.ClearFormatting
    87. '.Replacement.Text = " "
    88. '.Replacement.ClearFormatting
    89. '.Execute Replace:=wdReplaceOne, Forward:=True
    90. 'End With
    92. Next
    93. a.Close
    95. End If
    97. End Sub
    99. '#####FUNKTIONEN#######
    101. Private Function fncFolders(sfolder As String) As Variant
    102. Dim arr() As String
    103. Dim iCounter As Integer, ifolder As Integer
    104. ReDim arr(1 To 1)
    105. arr(1) = sfolder
    106. ifolder = 1
    107. For iCounter = Len(sfolder) To 4 Step -1
    108. If Mid(sfolder, iCounter, 1) = "\" Or iCounter = 1 Then
    109. ifolder = ifolder + 1
    110. ReDim Preserve arr(1 To ifolder)
    111. arr(ifolder) = Left(sfolder, iCounter - 1)
    112. End If
    113. Next iCounter
    114. fncFolders = arr
    115. End Function
    117. Private Function fncIfFolderExists(sfolder As String) As Boolean
    118. Dim sOld As String
    119. sOld = CurDir
    120. On Error Resume Next
    121. ChDrive Left(sfolder, 1)
    122. ChDir sfolder
    123. If Err = 0 Then fncIfFolderExists = True
    124. On Error GoTo 0
    125. ChDrive Left(sOld, 1)
    126. ChDir sOld
    127. End Function
    129. Private Function CheckPath(strPath As String) As Boolean
    130. If Dir$(strPath) <> "" Then
    131. CheckPath = True
    132. Else
    133. CheckPath = False
    134. End If
    135. End Function


    ich hoffe das schockiert hier niemanden, wenn ich hier soviel Code poste :whistling:

    Also ich habe da ein paar Probleme:

    Zeile 52)
    Hier soll überprüft werden wieviele ZEILEN aus der Tabelle selektiert wurden. Denn bei mehr als einer selektierten Zeile Funktioniert das makro nicht. (die 'eine' Zeile die erlaubt ist darf aber beliebig viele Spalten haben.)

    Leider funktioniert dieser Check nicht richtig. Stimmt da was mit den Objekten 'Selection.Tables(1).Rows.Count' nicht?

    Zeile 74 bis 80 )
    Nach 500 Zeichen soll ein Zeilenumbruch eingefügt werden. Das was da steht ist wohl eher ein verzweifelter Versuch von mir (der auch nicht funktioniert) Wie würdet ihr es machen?

    Zeile 83 bis 90)
    Aus irgendeinem Grund wird an einigen Stellen in der Textdatei auch dieses Quadrat-Teichen mit eingefügt (kann hier im Forum offensichtlich nicht angezeigt werden) Ich weiss nicht woran das liegt. Wie kann ich das verhindern?
    Ich habe versucht es mit einem Zeichenaustausch zu managen, aber das funktionierte leider nicht. Ich vermute mal deswegen, weil das Quadrat-Symbol erst beim Einfügen entsteht, und vorher ja nicht in der Word datei existiert.


    noch eine andere Frage: Wie kann ich das Ereignis abfangen, wenn der Benutzer bei einer InputBox auf die Abbrechen-Schaltfläche oder oben auf das 'X' des Dialoges klickt?

    Ich hoffe jmd. kann mir helfen, und ich habe mich verständlich ausgedrückt.


    MfG

    soegel

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „soegel“ ()

    zu Zeile 52)

    Lass Tables(1) weg. So wie du es jetzt hast, werden die Zeilen der gesamten Tabelle, innerhalb der sich die Markierung befindet, gezählt, also statt Zeile 52:

    Visual Basic-Quellcode

    1. If Selection.Rows.Count > 1 Then


    zu Zeile 74 bis 80)

    Ich denke, so müsste es funktionieren:

    Visual Basic-Quellcode

    1. For k = 1 To Len(Selection.Cells(i)) Step 500
    2. a.WriteLine Mid(Selection.Cells(i), k, 500)
    3. Next


    zu Zeile 83 bis 90)

    Am Ende jeder Zelle einer Word-Tabelle sind die Zeichen mit den ASCII-Werten 13 und 7. Das mit der 7 ist für das Quadrat verantwortlich.

    Ich nehme an, dass diese Zeichen im Range-String des Word-Dokuments enthalten sind, um Tabellenzellen kennzuzeichnen.

    Am besten weist du in Zeile 73 den Zellinhalt einer Variablen zu, wobei du die erwähnten 2 Zeichen abschneidest:

    Visual Basic-Quellcode

    1. Zellinhalt = Left(Selection.Cells(i), Len(Selection.Cells(i)) - 2)


    Und danach verwendest du überall statt "Selection.Cells(i)" diese Variable (auch in meinem Beispiel für die Zeilen 74 bis 80)


    Zu der X-Schaltfläche:

    Wenn man bei einer InputBox auf Abbrechen oder das X klickt, wird ein Leerstring ("") zurückgegeben.


    Noch ein paar Tipps:

    Versuche "GoTo" und "On Error ..." soweit es geht zu vermeiden. Es gibt seltene Fälle, bei denen ich es auch noch verwende, aber das sollte die Ausnahme ein.

    Wenn man GoTo benutzt, verliert der Code an Übersichtlichkeit.
    Ich würde statt der Zeilen 23 bis 39 folgendes machen:
    (Ich war so frei und hab aus der InputBox eine MsgBox gemacht.)

    Visual Basic-Quellcode

    1. Do
    2. FullFilePath = sOrdner & "\" & FileName & ".ts"
    3. If Dir(FullFilePath) = "" Then
    4. Exit Do
    5. Else
    6. If MsgBox("Die Datei existiert bereits." & Chr(13) & _
    7. "Überschreiben?", vbYesNo) = vbYes Then
    8. Exit Do
    9. Else
    10. FileName = InputBox("Anderen Dateinamen angeben. Dateiendung '.ts' wird automatisch angehängt.")
    11. End If
    12. End If
    13. Loop


    Und in Zeile 95 noch das "End If" entfernen.

    Wie du in meinem Beispiel siehst, ist es auch nicht viel aufwändiger ohne die Funktion "CheckPath".

    zu deiner FolderExists-Funktion:

    Das FileSystemObject-Objekt hat eine FolderExists-Methode (näheres in der VB-Hilfe). Das geht dann etwas einfacher als deine Funktion. Außerdem stört mich bei dir dieses "On Error ...".



    Ich hoffe, ich konnte dir damit weiterhelfen.

    Hallo,
    ich habe alles umgesetzt.
    Auch die FolderExists-Methode vom SystemObject-Object ist schon drin.
    Das ganze sieht jetzt so aus.

    Visual Basic-Quellcode

    1. Sub test()
    2. Dim i As Integer
    3. Dim FileName As String
    4. Dim arrOrdner As Variant
    5. Dim iOrdner As Integer
    6. Dim sDrive As String
    7. Dim sOrdner As String
    8. Dim sTmp As String
    9. Dim FullFilePath As String
    10. Dim Zelleninhalt As String
    11. Dim SpaceLen As Single
    13. If Selection.Rows.Count > 1 Then
    14. MsgBox ("Bitte nur eine Tabellenzeile markieren!")
    15. Exit Sub
    16. End If
    18. sOrdner = InputBox("Wo soll die Datei gespeichert werden. Pfad mit Laufwerksbuchstaben angeben. (zb: C:\Ordner1\Ordner2) (nicht vorhandene Verzeichnisse werden erstellt):")
    19. FileName = InputBox("Namen der Export-Datei angeben. Dateiendung '.ts' wird automatisch angehängt.")
    21. If sOrdner = "" Then Exit Sub
    22. If FileName = "" Then Exit Sub
    24. 'Eventuelles "\" am Ende des eingegebenen Pfades entfernen
    25. If Right(sOrdner, 1) = "\" Then
    26. sOrdner = Left(sOrdner, Len(sOrdner) - 1)
    27. End If
    29. 'Checkt die Existens der Datei
    30. Do
    31. FullFilePath = sOrdner & "\" & FileName & ".ts"
    32. If Dir(FullFilePath) = "" Then
    33. Exit Do
    34. Else
    35. If MsgBox("Die Datei existiert bereits." & Chr(13) & _
    36. "Überschreiben?", vbYesNo) = vbYes Then
    37. Exit Do
    38. Else
    39. Do
    40. FileName = InputBox("Anderen Dateinamen angeben. Dateiendung '.ts' wird automatisch angehängt.")
    41. If FileName = "" Then 'Export wird für Schaltfl. 'Abbrechen' und bei leerem Namen abbgebrochen
    42. MsgBox ("Exportierung abbgebrochen.")
    43. Exit Sub
    44. Else
    45. Exit Do
    46. End If
    47. Loop
    48. End If
    49. End If
    50. Loop
    52. Set fs = CreateObject("Scripting.FileSystemObject")
    54. arrOrdner = fncFolders(sOrdner)
    55. For iOrdner = UBound(arrOrdner) To 1 Step -1
    56. If fs.FolderExists(CStr(arrOrdner(iOrdner))) Then
    57. 'TeilOrdner überspringen, falls schon vorhanden
    58. iOrdner = iOrdner - 1
    59. Else
    60. 'andernsfalls TeilOrdner erstellen
    61. MkDir arrOrdner(iOrdner)
    62. End If
    63. Next iOrdner
    65. Set a = fs.CreateTextFile(sOrdner & "\" & FileName & ".ts", True)
    67. For i = 1 To Selection.Cells.Count
    68. ' Hier werden die "Überschriften" zugeordnet und Kommentar-Symbole vorgesetzt.
    69. ' Vorraussetzung ist, das die Zelleninhalte ohne Zeilenumbruch eingefügt werden.
    70. If i = 1 Then
    71. a.write ("# - Nummer: ")
    72. SpaceLen = 8
    73. ElseIf i = 2 Then
    74. a.writeline ("#")
    75. a.write ("# - Stichwort: ")
    76. SpaceLen = 11
    77. ElseIf i = 3 Then
    78. a.writeline ("#")
    79. a.write ("# - Beschreibung: ")
    80. SpaceLen = 14
    81. ElseIf i = 4 Then
    82. a.writeline ("#")
    83. a.write ("# - Erwartung: ")
    84. SpaceLen = 11
    85. Else
    86. a.writeline ("# ")
    87. SpaceLen = 2
    88. End If
    90. 'Inhalt der Aktuellen Zelle in Variable schreiben
    91. Zelleninhalt = Left((Selection.Cells(i)), Len((Selection.Cells(i))) - 2)
    93. 'Einfügen der Zelleninhalte
    94. For k = 1 To Len(Zelleninhalt) Step 500
    95. If k > 1 Then a.write ("# - " & Space(SpaceLen))
    96. a.writeline Mid(Zelleninhalt, k, 500)
    97. Next
    98. Next
    99. a.Close
    100. 'MsgBox Selection.Cells(i).Column.Index
    101. 'MsgBox Selection.Cells(i).Row.Index
    102. End Sub
    104. Private Function fncFolders(sfolder As String) As Variant
    105. Dim arr() As String
    106. Dim iCounter As Integer, ifolder As Integer
    107. ReDim arr(1 To 1)
    108. arr(1) = sfolder
    109. ifolder = 1
    110. For iCounter = Len(sfolder) To 4 Step -1
    111. If Mid(sfolder, iCounter, 1) = "\" Or iCounter = 1 Then
    112. ifolder = ifolder + 1
    113. ReDim Preserve arr(1 To ifolder)
    114. arr(ifolder) = Left(sfolder, iCounter - 1)
    115. End If
    116. Next iCounter
    117. fncFolders = arr
    118. End Function



    Ich habe das Programm jetzt mal umfangreichen Tests unterzogen, was das erstellen von Ordnern und den eigentlichen Export-Dateien betrifft. Dabei habe ich unterschiedliche Kombinationen ausprobiert.
    Beispielsweise:
    erst Export nach Z:\hallo\datei.ts
    danach nach Z:\hallo\Ordner2\datei.ts

    oder:
    erst Export nach Z:\hallo\hallo2\Ordner\datei.ts
    und dann: Z:\hallo\datei.ts

    Gelegentlich (bei bestimmten Kombinationen der vorhandenen und noch zu erstellenden Ordner) bekomme ich nun einen Laufzeitfehler 76 "Pfad nicht gefunden". Der Debugger zeigt auf "Set a = fs.CreateTextFile(sOrdner & "\" & FileName & ".ts", True)" (Zeile 65).

    Ich denke mal das mit Pfad nicht gefunden, "sOrdner" in dem Ausdruck gemeint ist.
    Das würde ja heissen, dass das was in den Zeilen 52 bis 63 steht, irgendwie nicht so ganz hinhaut. Also die Überprüfung/Erstellung des Ordnerbaumes.
    Mal funktionierts, mal nicht.
    Kann der Fachmann da irgendwas fadenscheiniges erkennen? Vllt ist meine Vermutung auch falsch und der Fehler liegt woanders.

    edit: tatsächlich scheint hier jemad ziehmlich das gleiche Problem zu haben: tek-tips.com/viewthread.cfm?qid=1161048&page=1.
    Die vorgeschlagene "Brute-Force"-Prozedur, ist die wirklich nötig? Ich hoffe noch, ich kann das problem schneller lösen und das es nur eine kleine sache ist :)

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „soegel“ ()

    In Zeile 58 machst du das:

    Visual Basic-Quellcode

    1. iOrdner = iOrdner - 1


    Das ist aber genau das, was "Next iOrdner" bei "Step -1" auch macht. Vielleicht liegt da der Hund begraben.

    Vielleicht hilft dir eine andere Herangehensweise:


    Visual Basic-Quellcode

    1. Private Function fncFolders(sfolder As String) As String()
    2. Dim arr() As String
    3. Dim iCounter As Integer, ifolder As Integer
    4. arr = Split(sfolder, "\")
    5. For iCounter = 1 To Ubound(arr)
    6. arr(iCounter) = arr(iCounter - 1) & "\" & arr(iCounter)
    7. Next
    8. fncFolders = arr
    9. End Function


    Die Split-Funktion erzeugt ein String-Array, das einen String am Trennzeichen trennt (mehr Infos in der VB-Hilfe).

    Wenn in obiger Funktion sfolder = "C:\Ordner1\Ordner2\Ordner3" ist, bekommt arr durch Split folgende Werte: arr(0)="C:", arr(1)="Ordner1", arr(2)="Ordner2", arr(3)="Ordner3".



    statt Zeile 54 bis 63:

    Visual Basic-Quellcode

    1. arrOrdner = fncFolders(sOrdner)
    2. For iOrdner = 1 To UBound(arrOrdner)
    3. If Not fs.FolderExists(arrOrdner(iOrdner)) Then
    4. MkDir arrOrdner(iOrdner)
    5. End If
    6. Next iOrdner



    Hab grad erst deinen Edit gesehen. Mein Code zielt im Prinzip auf das gleiche ab, wie die Lösung in deinem Link, das im Link ist nur noch etwas kürzer.

    Dann bräuchtest du nämlich statt der Zeilen 54 bis 63 nur das hier:

    Visual Basic-Quellcode

    1. myMkDir sOrdner

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

Facebook
Telefonspende