VBA Tipp: Word Tabellen auslesen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte mit Access eine in Word enthaltene Tabelle auslesen und die Daten spaltenweise in Acess Tabellen schreiben.

Die beiden Tabellen heißen hier tbl_Erste_Spalte und tbl_Zweite_Spalte um die Übersicht zu erhöhen. Bei folgendem Beispiel sind die Zeilen auf 50 beschränkt, was aber natürlich beliebig erweitert werden kann. Weiterhin muss auch die Funktion Suchen/Ersetzen(Replace) eingebunden werden und es muss auch ein Verweis auf die 'Microsoft WORD Object Library' gesetzt sein.

Lösung

Public Sub Wordanalyse(Pfad As String)
 
   Dim wrd As Word.Application
   Dim doc As Word.Document
 
   Dim tmp0(50) As String
   Dim tmp2(50) As String
   Dim tmp3(50) As String
   Dim tmp4(50) As String
 
   'Itaratoren
   Dim i As Long
   Dim j As Long
   Dim k As Long
 
   'Z = Zwischenwert
   Dim z As String
 
   'Die Aktuelle Datenbank
   Dim db  As Database
   Dim rs1 As Recordset
   Dim rs2 As Recordset
 
   Set db = CurrentDb
 
   'Tabellen werden geleert
   db.Execute "DELETE FROM tbl_Erste_Spalte"
   db.Execute "DELETE FROM tbl_Zweite_Spalte"
 
   Set rs1 = db.OpenRecordset("Select * from tbl_Erste_Spalte", dbOpenDynaset, dbAppendOnly)
   Set rs2 = db.OpenRecordset("Select * from tbl_Zweite_Spalte", dbOpenDynaset, dbAppendOnly)
 
   'Schauen, ob Word schon läuft
   On Error Resume Next   '
   Set wrd = GetObject(, "Word.Application")
   If Err.Number <> 0 Then
      Set wrd = CreateObject("Word.Application")
   Else
      wrd.Activate
      wrd.Visible = False
   End If
   On Error GoTo 0   'Debugging wieder einschalten
 
   'Dokument im "Nur Lesen"-Modus öffnen
   wrd.Documents.Open FileName:=Pfad, ReadOnly:=True
 
   'Erste Spalte einlesen
   i = 1   ' Ist die erste Zeile
 
   Do While i < 50   ' Maximale Anzahl der gelesenen Zeilen
      'Tabellen Zeilenumbrüche entfernen
      tmp0(i) = Replace(wrd.ActiveDocument.Tables(1).Cell(i, 1).Range, "?", vbNullString)
      ' Das Tables(1) -> Steht für die erste Tabelle im Dokument
      j = 1
 
      Do While j <= Len(tmp0(i))
         If Asc(Mid$(tmp0(i), j, 1)) >= 64 Then   ' Keine Sonderzeichen lesen
            z = z & Mid$(tmp0(i), j, 1)
         End If
         j = j + 1
      Loop
 
      If Len(z) > 0 Then
         tmp2(k) = z
         k = k + 1
      End If
 
      z = vbNullString
      i = i + 1
   Loop
 
   For i = 0 To UBound(tmp2)
      If Len(tmp2(i)) > 0 Then
         If tmp2(i) <> tmp2(i - 1) Then
            rs1.AddNew
            rs1!Ergebnis = Trim$(tmp2(i))
            rs1.Update
         End If
      End If
   Next
 
   'Zweite Spalte
   i = 1
   k = 0
 
   Do While i < 50
      'Tabellen Zeilenumbrüche entfernen
      tmp3(i) = Replace(wrd.ActiveDocument.Tables(1).Cell(i, 2).Range, "?", vbNullString)
      j = 1
 
      Do While j <= Len(tmp3(i))
         If Asc(Mid$(tmp3(i), j, 1)) >= 64 Then
            z = z & Mid$(tmp3(i), j, 1)
         End If
 
         j = j + 1
      Loop
 
      If Len(z) > 0 Then
         tmp4(k) = z
         k = k + 1
      End If
 
      z = vbNullString
      i = i + 1
   Loop
 
   For i = 0 To UBound(tmp4)
      If Len(tmp4(i)) > 0 Then
         If tmp4(i) <> tmp4(i - 1) Then
            rs2.AddNew
            rs2!Ergebnis = Trim$(tmp4(i))
            rs2.Update
         End If
      End If
   Next
 
   On Error Resume Next
   rs1.Close
   rs2.Close
End Sub
Wiki hinweis.png Hinweis: Es werden keine Sonderzeichen eingelesen aufgrund der Zeilenumbrüche innerhalb der Wordtabellen. Falls doch Sonderzeichen benötigt werden, wird empfohlen, den Ascii Code für dieses Zeichen zu ermitteln und an die ermittelte Stelle einzusetzen:
' Keine Sonderzeichen lesen außer einem Punkt(".")
If Asc(Mid(Tmp(i), J, 1)) >= 64 Or Asc(Mid(Tmp(i), J, 1))= 46 Then

Aufruf

   Call Wordanalyse("C:\EinPfad\EinWordDoc.docx")