Word Texte und Tabellen in Excel kopieren

Urs · 2017-02-24T14:47:08+00:00

Hallo Ich bin schon seit längerer Zeit daran in einem geschützten Word-Dokument Texte und Zahlen, die der User eingibt, in ein Excel pro Zeile zu schreiben. Was ich bereits habe, ist ein Makro, dass die ContentControls in einer MsgBox bringt. Ich müsste einfach anstelle der MsgBox die Einträge in eine externe Excel-Date beginnt in A1,A2,A3....bis Dokumentende. Da von den Usern verschiedene Worddokumente ausgefüllt werden, gibt es im Excel pro Zeile einen Eintrag. Wäre schön, wenn ich da weiterkommen könnte. Vielen Dank. Sub Test() Dim arrfelder() As Variant Dim sPfad As String Dim iCounter As Integer Dim Zelle As Range 'Pfad sPfad = "H:\Makros\Leistungsanalyse\" 'Dateiname sFile = "LEH_doku.xlsx" With ActiveDocument 'Felder der Reihe nach einlesen For i = 1 To .ContentControls.Count ReDim Preserve arrfelder(i) arrfelder(i) = .ContentControls(i).Range.Text Next i End With For i = 1 To UBound(arrfelder) MsgBox arrfelder(i) Next i End Sub

Hi Urs,
eine Möglichkeit ist, einfach die Indexe auszutauschen:

Sub TestQuer()
Dim arrfelder() As Variant
Dim sPfad As String, sDatei As String
Dim oEx As Object
Dim i As Long
sPfad = "C:\A_Forum_DL\"
sDatei = "ImportAusWord.xlsx"
With ActiveDocument
ReDim arrfelder(1 To 1, 1 To .ContentControls.Count) ' ***
For i = 1 To .ContentControls.Count
arrfelder(1, i) = .ContentControls(i).Range.Text ' ***
Next i
End With
For i = 1 To UBound(arrfelder, 2) ' ***
MsgBox arrfelder(1, i)         ' ***
Next i
Stop ' diese Zeile dann wieder rausnehmen
Set oEx = CreateObject("excel.application").Workbooks.Open(sPfad & sDatei)
oEx.sheets(1).Range("A1").Resize(1, i - 1) = arrfelder ' ***
oEx.Save
oEx.Close
Set oEx = Nothing
End Sub

Eine weitere, das ganze Ding allgemein zu gestalten:

Sub testallgAufrufen()
Call TestAllg("d3", "quer", "C:\A_Forum_DL\ImportAusWord.xlsx")
Call TestAllg("h5", "hoch", "C:\A_Forum_DL\ImportAusWord.xlsx")
End Sub
Sub TestAllg(r As String, wie As String, sPfadUndDatei As String)
Dim arrfelder() As Variant, a2
Dim oEx As Object
Dim i As Long
With ActiveDocument
ReDim arrfelder(1 To 1, 1 To .ContentControls.Count)
For i = 1 To .ContentControls.Count
arrfelder(1, i) = .ContentControls(i).Range.Text
Next i
End With
If wie = "hoch" Then
a2 = arrfelder
ReDim arrfelder(1 To UBound(a2, 2), 1 To 1)
For i = 1 To UBound(arrfelder): arrfelder(i, 1) = a2(1, i): Next
For i = 1 To UBound(arrfelder)
MsgBox arrfelder(i, 1)
Next i
Else
For i = 1 To UBound(arrfelder, 2)
MsgBox arrfelder(1, i)
Next i
End If
Set oEx = CreateObject("excel.application").Workbooks.Open(sPfadUndDatei)
If wie = "hoch" Then
oEx.sheets(1).Range(r).Resize(UBound(arrfelder), 1) = arrfelder
Else
oEx.sheets(1).Range(r).Resize(1, UBound(arrfelder, 2)) = arrfelder
End If
oEx.Save
oEx.Close
Set oEx = Nothing
End Sub

Hier kannst Du die Zelle eingeben, ab der geschrieben werden soll, bei wie=hoch wird von A1:An geschrieben, ansonsten nach rechts.
Zeilenweise könntest Du es dann z.B. so aufrufen:

Dim z as Long
for z=1 to 3
' hier Deine Anweisungen, z.B. Laden einer anderen Word-Datei
' die wäre dann das jeweils neue ActiveDocument
Call TestAllg("A" & z, "quer", "C:\A_Forum_DL\ImportAusWord.xlsx")
next

"A" & z ist dann jeweils A1, A2 usw.
Schöne Grüße,
Michael

Hi,
ich habe doch mal etwas Word-VBA recherchiert.
Insgesamt und mit nur *einem* Zugriff auf Excel funktioniert es so:

Option Explicit
Sub DateinImPfad()
'Quelle:
'http://www.ms-office-forum.net/forum/showthread.php?t=266560
'Dim wrdDoc As Document wegen With nicht benötigt
Dim wPfad As String, xPfad As String   ' Word- und Excel-Pfad
Dim wDatei As String, xDatei As String ' Word- und Excel-Dateiname
Dim dirDatei As String                 ' Dateiname für Dir-Befehl
Dim a(), b(), i&, aMax&, j&
Dim o As Object, oo
wPfad = "C:\A_Forum_DL\"
xPfad = "C:\A_Forum_DL\"
xDatei = "ImportAusWord.xlsx"
wDatei = "ImportAusWord_D"
dirDatei = Dir(wPfad & wDatei & "*.docx")
If dirDatei  "" Then Set o = CreateObject("scripting.dictionary")
Do While dirDatei > ""
With Documents.Open(wPfad & dirDatei, ReadOnly:=True)
MsgBox .Name & " wurde geöffnet" ' ggf auskommentieren
ReDim a(1 To 1, 1 To .ContentControls.Count) ' ***
For i = 1 To .ContentControls.Count
a(1, i) = .ContentControls(i).Range.Text ' ***
Next i
.Close
End With
o(dirDatei) = a   ' die eingelesene Zeile im dictionary gespeichert
If UBound(a, 2) > aMax Then aMax = UBound(a, 2)
' die höchste Spaltenanzahl ermitteln
dirDatei = Dir
Loop
Stop
If o.Count >= 1 Then
ReDim a(1 To o.Count, 0 To aMax)
i = 0
For Each oo In o.keys
i = i + 1
a(i, 0) = oo
b = o(oo)
For j = 1 To UBound(b, 2)
a(i, j) = b(1, j)
Next
Next
With CreateObject("excel.application").Workbooks.Open(xPfad & xDatei)
MsgBox .Name & ": " & UBound(a) & " Zeilen übernommen."
.sheets(1).Range("A2").Resize(i, aMax + 1) = a ' ab A2 wegen evtl. Überschriften
' aMax + 1, weil a ab (0,xx) dimensioniert: Spalte 0 enthält den Dateinamen
.Save
.Close
End With
Set o = Nothing
Else
MsgBox "keine Datein gefunden"
End If
End Sub

Die Pfade und den Dateifilter für die Word-Dokumente (wDatei) mußt Du halt anpassen.
Ich habe mich zur Verwendung eines Dictionaries entschlossen: das bietet sich deshalb an, weil man zunächst nicht weiß, wie viele Word-Dateien gelesen werden. Mit einem Array müßte man "ewig" ein Redim Preserve machen, was Zeit kostet: außerdem ist nicht auszuschließen, daß eine der Wort-Datei mehr Controls enthält als die anderen: auch das ist ein Hindernis bei der Dimensionierung von Arrays.
Das Dictionary hingegen "frißt alles", und anhand der maximalen Anzahl von Controls (aMax) läßt sich ein Array problemlos *nach dem Einlesen* auf die benötigten Grenzen dimensionieren.
Ich habe zusätzlich zur Master- oder Makrodatei ein paar Kopien ohne Makro (.xlsx) angelegt, die Controls enthalten. Diese werden eingelesen.
Falls auch die Makros enthalten können, müßte man in der Schleife abfragen, ob der Name der aufrufendenen Datei bei Dir erreicht wird: die MakroDatei soll ja *nicht* importiert werden. Da wäre eine If-Verzweigung einzusetzen á la

Do While dirDatei > ""
If dirDatei  ThisDocument.Name Then
With Documents.Open(wPfad & dirDatei, ReadOnly:=True)

Ok, das neue Makro befindet sich im Modul "Michael".
Anbei alle 4 Dateien gezipt (Makro, 2 x Dokument mit Daten, Excel-Datei): https://www.herber.de/bbs/user/111827.zip
Schöne Grüße,
Michael

Word Texte und Tabellen in Excel kopieren

Forumthread: Word Texte und Tabellen in Excel kopieren

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Word Texte und Tabellen in Excel kopieren

Forumthread: Word Texte und Tabellen in Excel kopieren

22 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread