Letzte Zeile in Word abfragen
Philipp
Datei:http://www.file-upload.net/download-4120729/SV-9016.doc.html
Auf der 2ten Seite könnt ihr sehen: Höhe und Datum.
Ich möchte nun immer den letzten Wert nach Excel transferieren. Wie geht das?
Mein bisheriger Code:
Option Explicit
Dim blnTMP As Boolean
Dim objApp As Object
Public Sub Main()
Dim strPfad As String
On Error GoTo Fin
strPfad = "C:\Documents and Settings\geyerphi\Desktop\VERBINDUNG CHEMSERV\DATEN\"
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
Set objApp = OffApp("Word")
ActiveSheet.Range("B2:Z300").Clear
If Not objApp Is Nothing Then
'Columns("A:C").Clear
'SearchFiles strPfad, "*.doc", False ' ohne Unterordner
SearchFiles strPfad, "*.doc", True ' mit Unterordner
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Err.Number 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
Optional blnTMP As Boolean = False)
Dim objDocument As Object
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Set objDocument = objApp.Documents.Open _
(objFile.Path)
'Schreibgeschützte Word-Dateien werden entsperrt
'(objApp.ActiveDocument.Unprotect)
Dim OriginalProtection As WdProtectionType
OriginalProtection = objApp.ActiveDocument.ProtectionType
If OriginalProtection wdNoProtection Then objApp.ActiveDocument.Unprotect
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(2, 2).Range, _
Chr(13) & Chr(7), ""), "", ""), Chr(13), "")
'Ausgabe der Zeile Auftraggeber
Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(3, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Bestell - Nr- / WA - Nr.
Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(4, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile SV-NR.
Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(5, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Bau / Firma
Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(6, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Einbauort
Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(Replace(objDocument.Tables(1).Cell(7, 2).Range, _
Chr(13) & Chr(7), ""), "/ - ° C", ""), "-", ""), Chr(9), "")
'Ausgabe der Zeile Medium / Temperatur
Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(13, 2).Range, _
Chr(13) & Chr(7), ""), "mm", ""), Chr(9), "")
'Ausgabe der Zeile Einstellhöhe
Range("I" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(14, 2).Range, _
Chr(13) & Chr(7), ""), "bar", ""), Chr(9), "")
'Ausgabe der Zeile Einstelldruck
Range("J" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(19, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Federnummer
Range("K" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(20, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Bauteilkennzeichnung
Range("L" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(objDocument.Tables(1).Cell(22, 2).Range, _
Chr(13) & Chr(7), ""), "Ausflussziffer ( W ) -", "")
'Ausgabe der Zeile Ausflussziffer
Range("M" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(23, 1).Range, _
Chr(13) & Chr(7), ""), "Hersteller:", ""), Chr(9), "")
'Ausgabe der Zeile Hersteller
Range("N" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(23, 2).Range, _
Chr(13) & Chr(7), ""), "Figur : ", ""), Chr(13), "")
'Ausgabe der Zeile Figur
Range("O" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(objDocument.Tables(1).Cell(23, 3).Range, _
Chr(13) & Chr(7), ""), "PN : ", "")
'Ausgabe der Zeile PN
Range("P" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(24, 1).Range, _
Chr(13) & Chr(7), ""), "Eingang :", ""), Chr(9), "")
'Ausgabe der Zeile Eingang
Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(25, 1).Range, _
Chr(13) & Chr(7), ""), "Ausgang :", ""), Chr(9), "")
'Ausgabe der Zeile Ausgang
Range("R" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(Replace(objDocument.Tables(1).Cell(26, 1).Range, _
Chr(13) & Chr(7), ""), "Werkstoff :", ""), Chr(13), ""), Chr(9), "")
'Ausgabe der Zeile Werkstoff Werkstoff :
Range("S" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(26, 2).Range, _
Chr(13) & Chr(7), ""), "Ventiltype :", ""), Chr(13), "")
'Ausgabe der Zeile Ventiltype
Range("T" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(1).Cell(27, 3).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Abnahme durch
Range("U" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(objDocument.Tables(1).Cell(28, 1).Range, _
Chr(13) & Chr(7), ""), "Datum :", "")
'Ausgabe der Zeile Datum
Range("V" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(31, 1).Range, _
Chr(13) & Chr(7), ""), "Reparatur durchgeführt :", ""), Chr(9), "")
'Ausgabe der Zeile Reperatur durchgeführt
Range("W" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(Replace(Replace(objDocument.Tables(1).Cell(32, 1).Range, _
Chr(13) & Chr(7), ""), "Datum :", ""), Chr(9), "")
'Ausgabe der Zeile Datum
Range("X" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(2).Cell(3, 2).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Höhe
Range("Y" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
Replace(objDocument.Tables(2).Cell(3, 3).Range, _
Chr(13) & Chr(7), "")
'Ausgabe der Zeile Datum
objDocument.Close False
End If
Next objFile
If blnTMP = True Then
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
Next objFolder
End If
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