Word Texte und Tabellen in Excel kopieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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 'neu: xlsx-Datei: Summary existiert set WS = createobject("c:\temp\Summary.xlsx") WS.sheets(1).cells(1) = application.transpose(arrfelder) WS.close 1 For i = 1 To UBound(arrfelder) MsgBox arrfelder(i) Next i End Sub

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

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

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

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

Sub Test() For z = 1 To 1 Call TestAllg("A" & z, "", "H:\Makros\Leistungsanalyse\LEH_doku.xlsx") Next End Sub Sub TestAllg(r As String, wie As String, sPfadUndDatei As String) Dim arrfelder() As Variant 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 Set oEx = CreateObject("excel.application").Workbooks.Open(sPfadUndDatei) oEx.sheets(1).Range(r).Resize(1, UBound(arrfelder, 2)) = arrfelder oEx.Save oEx.Close Set oEx = Nothing End Sub

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

Private Sub Workbook_Open() Worksheets("Dok").Range("A1:ZZ1").Copy Worksheets("Final").Cells(Worksheets("Final").Rows.Count, 1).End(xlUp).Offset(1, 0). _ PasteSpecial Paste:=xlValues Application.CutCopyMode = False Columns("A:ZZ").Sort Key1:=Range("A1"), Order1:=xlAscending, _ Key2:=Range("B1"), Order2:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 6)), Cells(Rows.Count, 6) _ .End(xlUp).Row, Rows.Count) _ 'Es wird der letzten Eintrag ermittelt ActiveSheet.Range("a1:ZZ1000" & lngLetzte).RemoveDuplicates _ Columns:=Array(1, 2, 6, 30, 31), Header:=xlYes Range("A1").Select End Sub

Beliebteste Forumthreads (12 Monate)

Word Texte und Tabellen in Excel kopieren

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Word Texte und Tabellen in Excel kopieren

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

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread