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