Adressen aus Word in Excel-DB übertragen

Computer: Software & Programmierung Office Software
1

Hallo

leider geben mir meine Excel- und Word Fachbücher keine Hinweise, wie man das ohne erneutes manuelles Eintippen aus Word übertragen kan
Die (800) Adressen in Word haben folgenden Aufbau:

Leder - Bayer
Maulburgstr. 10, 67346 Speyer

Tel: (06232) 3 68 23

Branche: Lederwaren

und sollen in eine Excel DB folgender Struktur:

Branche PLZ Ort Strasse Firmenname Tel Fax

Hat jemand eine Empfehlung wie man die Adressdetails transferieren kann ?

Danke im voraus.

frdl.Gruß
nosp52

2

leider geben mir meine Excel- und Word Fachbücher keine
Hinweise, wie man das ohne erneutes manuelles Eintippen aus
Word übertragen kan
Die (800) Adressen in Word haben folgenden Aufbau:
und sollen in eine Excel DB folgender Struktur:

Branche PLZ Ort Strasse Firmenname Tel Fax
Hat jemand eine Empfehlung wie man die Adressdetails
transferieren kann ?

Hallo Nosp,

viel mehr Beispieldatensätze wären sehr hilfreich.

Alt+F11, Einfügen–Modul, Code reinkopieren, Editor schließen.
Aufruf in Excel mit Alt+F8…
Das Worddokument muß geöffnet sein.

Gruß
Reinhard

Option Explicit

Sub Importieren()
'Hinweis:
'Extras---Verweise: Verweis setzen auf Microsoft Word X.0 Object Library!
Dim objWord, W, N, arrW(1000, 3), Zei As Long, Z As Long, S As Long
On Error GoTo hell
Set objWord = GetObject(, "Word.Application")
W = Split(objWord.ActiveDocument.Content, Chr(11))
For N = 0 To UBound(W)
 If W(N) "" Then
 If Asc(W(N)) \>= 32 Then
 arrW(Z, S) = W(N)
 S = S + 1
 If S = 4 Then
 Z = Z + 1
 S = 0
 End If
 End If
 End If
Next N
With Worksheets("Tabelle1")
 Application.ScreenUpdating = False
 .Range("A1:F1").Value = Split("Branche PLZ Ort Strasse Firmenname Tel/Fax")
 .Range("G2:J1001") = arrW
 Zei = .Cells(Rows.Count, 7).End(xlUp).Row
 .Range("A2:A" & Zei).FormulaLocal = "=Wechseln(J2;""Branche: "";"""")"
 .Range("B2:B" & Zei).FormulaLocal = "=Teil(H2;Finden("","";H2)+2;5)"
 .Range("C2:C" & Zei).FormulaLocal = "=Teil(H2;Finden("","";H2)+8;99)"
 .Range("D2:smiley:" & Zei).FormulaLocal = "=Links(H2;Finden("","";H2)-1)"
 .Range("E2:E" & Zei).FormulaLocal = "=G2"
 .Range("F2:F" & Zei).FormulaLocal = "=Teil(I2;6;99)"
 .Range("A2:F" & Zei).Value = .Range("A2:F" & Zei).Value
 .Range("G:J").ClearContents
 .Range("A:F").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
hell:
If Err.Number 0 Then MsgBox Err.Number & vbCr & Err.Description
End Sub