OpenOffice.info

Verfasst: **Do, 07.05.2015 14:30**

Hallo zusammen,

ich habe eine Frage bzgl. Basic in Calc. Mein Ziel ist es, aus einem immer identisch aufgebauten Text-Formular alle Zeilen zu kopieren, die Text enthalten. Ich habe bereits einen Code (in VBA - habe leider absolut keine Ahnung von Basic) geschrieben der mir alle Zellen dieser Tabelle kopiert - sofern sie nicht leer sind. Der besagte (wirklich nicht schöne Code) sieht folgendermaßen aus:

Code: Alles auswählen

Option Explicit
Dim blnTMP As Boolean
Public Sub Daten_auslesen()
    Dim objDocument As Object
    Dim strDatei As String
    Dim strPfad As String
    Dim objApp As Object
    On Error GoTo Fin
    ' Pfad anpassen
    strPfad = "I:\Eigene Dateien\"
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            Set objDocument = objApp.Documents.Open _
                (strPfad & strDatei)
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(1, 1).Range, _
                Chr(13) & Chr(7), "")
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(2, 1).Range, _
                Chr(13) & Chr(7), "")
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(3, 1).Range, _
                Chr(13) & Chr(7), "")
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(4, 1).Range, _
                Chr(13) & Chr(7), "")
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(5, 1).Range, _
                Chr(13) & Chr(7), "")
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(1, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(2, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(3, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(4, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(5, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(1, 3).Range, _
                Chr(13) & Chr(7), "")
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(2, 3).Range, _
                Chr(13) & Chr(7), "")
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(3, 3).Range, _
                Chr(13) & Chr(7), "")
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(4, 3).Range, _
                Chr(13) & Chr(7), "")
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(3).Cell(5, 3).Range, _
                Chr(13) & Chr(7), "")
            Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(1, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(1, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(1, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(1, 2).Range, _
                Chr(13) & Chr(7), "")
            Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(1, 2).Range, _
                Chr(13) & Chr(7), "")
            objDocument.Close False
            ' Die nächste Datei nehmen
            strDatei = Dir$()
        Loop
        MsgBox "Daten erfolgreich übertragen!"
    Else
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Mein Ziel ist es wie gesagt, dass die gesamte Zeile der 3. Tabelle des Worddokuments kopiert wird, wenn in die erste Spalte ein Text eingetragen wurde. Aktuell werden alle Werte der einzelnen Zellen untereinander kopiert, sodass ggf. entstehende Leerzeilen nicht mitkopiert werden.

Ich hoffe dass ihr mir helfen könnt, bei den "Kollegen" vom Microsoft-Forum habe ich leider keine Antwort erhalten...
Vielen Dank im Voraus
Jerome

Verfasst: **Do, 07.05.2015 18:12**

Ich hab eigentlich nicht wirklich Lust den Übersetzungsaffen für diesen kranken VBA-kram zu geben --

Sehe ich es richtig das :

a. die Daten aus der vierspaltigen 3. doc-tabelle alle zellenweise untereinander in Spalte A rein kopiert werden sollen?
b. zum Schluss auch nochmal ein paar Zellen aus doc-tabelle Nr.1
c. das Ding auch noch über sämtliche *.doc -files eines Verzeichnisses iteriert.

Am besten wäre es, wenn du eine dieser Quelldateien mit nicht-vertraulichen Dummy-daten bestückst und als ..odt hier anhängst, und dann nochmal das gleiche für die Zieldatenstruktur als ...ods -datei

Verfasst: **Di, 12.05.2015 08:28**

Hallo, erstmal Danke für deine schnelle Antwort!

Also, zu

a. es sollen alle Daten der x.-ten (in dem Fall der angehänten Dokumente der 1.) Tabelle zeilenweise in die Spalten A und B kopiert werden
b. nur aus der anfangs gewählten Tabelle sollen Daten kopiert werden
c. das Ding soll über sämtliche files eines Verzeichnisses iterieren

Anbei die Quelldateien zu meinem Problem.

Test.rar: (40.76 KiB) 82-mal heruntergeladen

Danke im Voraus

OpenOffice.info

Basic - Bestimmte Zeilen einer Tabelle aus einer Text-Datei nach Calc kopieren

Basic - Bestimmte Zeilen einer Tabelle aus einer Text-Datei nach Calc kopieren

Re: Basic - Bestimmte Zeilen einer Tabelle aus einer Text-Datei nach Calc kopieren

Re: Basic - Bestimmte Zeilen einer Tabelle aus einer Text-Datei nach Calc kopieren