Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro um aus einem Wordformular eine Excelliste

Makro um aus einem Wordformular eine Excelliste
13.05.2013 22:42:21
Anna
Hallo,
ich brauch eure Hilfe weil ich leider alleine nicht mal bis zur ersten Zeile komme.
Gibt es eine Möglichkeit um jede Menge Word Formulare in Excel zu verarbeiten?
Genau genommen sind es immer einseitige Wordformulare von denen ich aktuell immer 1 Zeile untereinander in eine Exceltabelle kopiere. Die Dateien liegen alle im gleichen Ordner. Es ist sehr langwierig und nervenaufreibend jedes einzelne Word zu öffnen und die Zeile zu kopieren. Kann man das automatisieren?
Für Ideen und Tips bin ich sehr dankbar.
Schöne Grüße
Anna

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro um aus einem Wordformular eine Excelliste
14.05.2013 07:38:32
Case
Hallo, :-)
wenn Du ein paar Worddateien gezippt - gegebenenfalls mit anonymisierten Daten - zur Verfügung stellst (also hier hochlädst) und die Zeile die kopiert werden soll nennst, kann man da schon was machen. :-)
Servus
Case

AW: Makro um aus einem Wordformular eine Excelliste
14.05.2013 15:40:33
Anna
Hallo Case,
oha, das geht aber schnell mit den Antworten, vielen Dank! Bin beeindruckt *freu*.
Hab mal 3 Worddateien und die "Zielexcel" gezipt. In den Wordfiles hab ich die Wunschdaten gelb hinterlegt.
https://www.herber.de/bbs/user/85325.zip
Grüssle
Anna

Anzeige
Hier mal eine Möglichkeit...
14.05.2013 21:58:58
Case
Hallo Anna, :-)
hier erstmal Deine Dateien zurück:
Excel- und Worddateien...
Der Code ist in der Datei "Reiseantraege.xls" (ich mag weder Umlaute noch Sonderzeichen in Datei- bzw. Ordnernamen). :-)
Mit Deinen Testdateien funktioniert es. ;-)
Der Code:
Option Explicit
' Unterordner bei Bedarf anpassen
Const strSubFolder As String = "Reiseantraege"
Dim blnTMP As Boolean
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.05.2013
' Purpose   : Word - Tabelle - Zellen auslesen...
Public Sub Main()
Dim objDocument As Object
Dim strFile As String
Dim strPath As String
Dim objApp As Object
Dim lngCalc As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
With Application
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating = False
' Ereignisroutinen werden deaktiviert
.EnableEvents = False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc = .Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation = xlCalculationManual
'  Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts = False
End With
' Pfad gegebenenfalls anpassen
strPath = ThisWorkbook.Path & Application.PathSeparator & _
strSubFolder & Application.PathSeparator
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
With ThisWorkbook.Worksheets("Tabelle1")
.Range(.Rows(3), .Rows(Rows.Count)).ClearContents
strFile = Dir$(strPath & "*.doc*", vbDirectory)
Do While strFile  ""
Set objDocument = objApp.Documents.Open(strPath & strFile)
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(4).Cell(2, 1).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 1).Value = _
Replace(objDocument.Tables(4).Cell(2, 2).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 3).Value = _
Replace(objDocument.Tables(5).Cell(2, 1).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 4).Value = _
Replace(objDocument.Tables(5).Cell(2, 2).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 5).Value = _
Replace(objDocument.Tables(5).Cell(2, 3).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 6).Value = _
Replace(objDocument.Tables(5).Cell(2, 4).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 7).Value = _
Replace(objDocument.Tables(5).Cell(2, 5).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 8).Value = _
Replace(objDocument.Tables(5).Cell(2, 6).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 10).Value = _
Replace(objDocument.Tables(5).Cell(3, 1).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 11).Value = _
Replace(objDocument.Tables(5).Cell(3, 2).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 12).Value = _
Replace(objDocument.Tables(5).Cell(3, 3).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 13).Value = _
Replace(objDocument.Tables(5).Cell(3, 4).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 14).Value = _
Replace(objDocument.Tables(5).Cell(3, 5).Range, _
Chr(13) & Chr(7), "")
.Range("A" & .Rows.Count).End(xlUp).Offset(0, 15).Value = _
Replace(objDocument.Tables(5).Cell(3, 6).Range, _
Chr(13) & Chr(7), "")
objDocument.Close False
strFile = Dir$()
Loop
End With
Else
MsgBox "Application not installed!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen zurücksetzen
Set objDocument = Nothing
Set objApp = Nothing
' Die Applikation aufwecken
With Application
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating = True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents = True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation = lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts = True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
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
In meinem Blog habe ich unter dem Label "Word" noch verschiedene andere Codes in Bezug auf Excel-Word-Excel.
Vielleicht noch interessant...
Servus
Case

Anzeige
AW: Hier mal eine Möglichkeit...
14.05.2013 22:35:55
Anna
Yeah Yeah Yeah! Wie cool ist das denn! Würde dir ja jetzt glatt um den Hals fallen!!!!
Hab zwar keine Ahnung was du da gebastelt hast aber es funktioniert 1a! Und es ist ganz egal wie meine Worddateien heißen und es aktualisiert alle Zeilen automatisch, ich glaub ich traeum!
Sorry fuer die Umlaute und Sonderzeichen, ich schreib halt eher Briefe wie Programme, gelobe feierlich Besserung!!! ;-)

318 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige