Hallo PeeT,
Sofern du's nicht schon anderweitig erledigt hast:
Ich hab mich mal nach deinen Angaben versucht, wobei ich natürlich keine großartige Test-Umgebung aufgebaut hab. Das Routinchen ist für ein neues Modul in bel. *.do? gedacht. Es erwartet alle zu untersuchenden Dok's im Pfad "PFAD". Ich würde empfehlen, zum Test mal mit wenigen anzufangen.
Es wird dann also in jedem Dok nach dem 1. rein numerischen Wort gesucht (CH-12345 wäre also "ungültig"), darüber wird die Strasse vermutet (allenfalls leere Absätze dazwischen) und im 1. Absatz Anrede, Vorname(n) und Nachnamen. Das Ergebnis wird einstweilen Tab-getrennt in ein leeres Dok ausgegeben.
Es bleibt sicher viel Spielraum für Unwägbarkeiten, aber vielleicht kannst du deinen Job zumindest abkürzen.
Bei recht vielen mag Word schon mal in die Knie gehen.
Ich denke, du schaffst notwendige Anpassungen/ggf. Erweiterungen allein, wenn nicht ...
Option Explicit
Type ADRESSE
Index As Long
Dok As String
Anrede As String
Vorname As String
Nachname As String
Straße As String
Plz As String
Ort As String
Rest As String
' ggf. weitere wie Ansprechpartner, ...
End Type
Sub AdressenAusDoksAuslesen()
Const PFAD = "U:\Test\Adressen" ' Pfad, in dem alle fraglichen *.doc stehen sollten
Dim aAdr() As ADRESSE
Dim objDoc As Word.Document
Dim lTot As Long, L As Long, lP As Long, lOk As Long
Dim sP As String
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = PFAD
.SearchSubFolders = False
.FileName = "*.doc" ' ggf. weiter einschränken oder erweitern
.Execute
lTot = .FoundFiles.Count
If lTot > 0 Then
Application.ScreenUpdating = False
For L = 1 To lTot
lP = 1: sP = ""
Set objDoc = Documents.Open(.FoundFiles(L), False, True, False)
With objDoc
StatusBar = "Dokument " & L & " von " & lTot & " wird verarbeitet: " & .Name
' "Plz suchen" => Mindest-Kriterium
Do While Not IsNumeric(sP)
' davon ausgehend, dass es sich stets um Absätze handelt
sP = Trim(.Paragraphs(lP).Range.Words(1).Text)
lP = lP + 1
If lP = .Paragraphs.Count Then Exit Do
Loop
If IsNumeric(sP) And lP > 2 Then
lP = lP - 1
ReDim Preserve aAdr(lOk)
aAdr(lOk).Index = L
aAdr(lOk).Dok = .Name
aAdr(lOk).Plz = sP
If .Paragraphs(lP).Range.Words.Count > 1 Then
sP = Trim(Mid(.Paragraphs(lP).Range, Len(sP) + 1))
If Len(sP) > 0 Then sP = Left(sP, Len(sP) - 1)
aAdr(lOk).Ort = sP
' darüber Strasse, ggf. leere Absätze dazwischen
Do While lP > 1
lP = lP - 1
sP = Trim(.Paragraphs(lP).Range.Text)
If Len(sP) > 1 Then
aAdr(lOk).Straße = Left(sP, Len(sP) - 1)
Exit Do
End If
Loop
' alles zwischen hier und 1. Absatz mal in Rest packen (ggf. Probs in Excel wg. Umbrüchen)
If lP > 2 Then
sP = .Range(.Paragraphs(2).Range.Start, .Paragraphs(lP).Range.End - 1)
' ggf. replace auf chr(10) und chr(13)
aAdr(lOk).Rest = Trim(sP)
End If
' 1. Absatz => natürlich bes. vage so
aAdr(lOk).Anrede = Trim(.Paragraphs(1).Range.Words(1).Text)
aAdr(lOk).Nachname = Trim(.Paragraphs(1).Range.Words(.Paragraphs(1).Range.Words.Count - 1).Text)
sP = Trim(.Range(.Paragraphs(1).Range.Words(1).End, .Paragraphs(1).Range.Words.Last.Start))
sP = Left(sP, Len(sP) - Len(aAdr(lOk).Nachname))
aAdr(lOk).Vorname = Trim(sP)
End If
lOk = lOk + 1
End If
.Close 0
End With
Application.ScreenUpdating = True
Next L
End If
End With
Ausgabe:
sP = ""
For L = LBound(aAdr) To UBound(aAdr)
sP = sP & aAdr(L).Index & vbTab _
& aAdr(L).Dok & vbTab _
& aAdr(L).Anrede & vbTab _
& aAdr(L).Vorname & vbTab _
& aAdr(L).Nachname & vbTab _
& aAdr(L).Straße & vbTab _
& aAdr(L).Plz & vbTab _
& aAdr(L).Ort & vbTab _
& aAdr(L).Rest & vbCrLf
Next L
' zunächst mal in ein leeres Dok, wenn's so halbwegs passt, ist *.xls nicht mehr weit
Set objDoc = Documents.Add
objDoc.Range.InsertAfter sP
End Sub
Gruß
Uli
Uli M
