AW: Liste mit Adressen in ein Tabellen-Format brin
21.11.2006 21:27:21
fcs
Hallo Peter,
hier ein Konvertierungs-Makro.
Du solltes allerdings etwas vorsichtiger sein hier persönliche Daten anderer Personen in Tabellen einzustellen.
Potentiellen Helfern hast du es selber schwer gemacht, dadurch dass du die Klammern direkt an den Hyperlink des Exelfiles gesetzt hast. So funktiniert der Link nicht mehr korrekt.
Gruss
Franz
Sub AdressKonverter()
Dim wksQuelle As Worksheet, wksZiel As Worksheet, ZeileQ As Long, ZeileZ As Long
Dim Zelle As Range, Titel, Text as String
Set wksQuelle = Worksheets("Quelle")
Set wksZiel = Worksheets("Ziel")
Titel = Array("Dr.", "Professor") ' diese Liste ggf. um Einträge ergänzen
ZeileZ = 2 '1. Zeile für Eintrag in Zieltabelle
With wksQuelle
For ZeileQ = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(ZeileQ, "A").Value = "Anschrift" Then
Set Zelle = .Cells(ZeileQ, "A")
'Titel Name Vorname auflösen
Text = Zelle.Offset(1, 0).Value
'Auf Titel prüfen
For I = 0 To UBound(Titel)
If Left(Text, Len(Titel(I)) + 1) = Titel(I) & " " Then
wksZiel.Cells(ZeileZ, "B") = Titel(I)
'Titel abtrennen
Text = Right(Text, Len(Text) - Len(Titel(I)) - 1)
Exit For
End If
Next I
'Name eintragen
wksZiel.Cells(ZeileZ, "A") = Text
'Name und Vorname Trennen
'Anzahl Leerzeichen im Text
LZ = Len(Text) - Len(Application.WorksheetFunction.Substitute(Text, " ", ""))
If LZ > 1 Then 'Personen mit Doppelvornamen oder Nachname aus mehreren Worten
wksZiel.Cells(ZeileZ, "C") = Trim(InputBox("Bitte den Nachnamen löschen", "Vornamen auslesen - Doppelvor-/-nachname", Text))
Else
wksZiel.Cells(ZeileZ, "C") = Left(Text, InStr(1, Text, " ") - 1)
End If
wksZiel.Cells(ZeileZ, "D") = Mid(Text, Len(wksZiel.Cells(ZeileZ, "C")) + 2)
'Strasse übertragen
wksZiel.Cells(ZeileZ, "E") = Zelle.Offset(2, 0)
'PLZ übertragen
wksZiel.Cells(ZeileZ, "F") = Left(Zelle.Offset(3, 0), 5)
'Ort übertragen
wksZiel.Cells(ZeileZ, "G") = Mid(Zelle.Offset(3, 0), 7)
'Telefon übertragen
Text = Zelle.Offset(1, 1).Value
If Len(Text) > InStr(1, Text, ":") + 2 Then
wksZiel.Cells(ZeileZ, "H") = Trim(Mid(Text, InStr(1, Text, ":") + 1))
End If
'Fax übertragen
Text = Zelle.Offset(2, 1).Value
If Len(Text) > InStr(1, Text, ":") + 2 Then
wksZiel.Cells(ZeileZ, "I") = Trim(Mid(Text, InStr(1, Text, ":") + 1))
End If
'e-mail übertragen
Text = Zelle.Offset(3, 1).Value
If Len(Text) > InStr(1, Text, ":") + 2 Then
wksZiel.Cells(ZeileZ, "J") = Trim(Mid(Text, InStr(1, Text, ":") + 1))
End If
'www übertragen
Text = Zelle.Offset(4, 1).Value
If Len(Text) > InStr(1, Text, ":") + 2 Then
wksZiel.Cells(ZeileZ, "K") = Trim(Mid(Text, InStr(1, Text, ":") + 1))
End If
ZeileZ = ZeileZ + 1
End If
Next ZeileQ
End With
End Sub