Zellen je nach Inhalt automatisch in richtige Spalte verschieben

  • #1
B

Basti.Basti

Neues Mitglied
Themenersteller
Dabei seit
15.07.2013
Beiträge
4
Reaktionspunkte
0
Hallo Zusammen,

ich habe eine wichtige Frage. Mir liegt eine Liste von Adressen vor, bei der Namen, Telefonnummer, Faxnummer... enthalten sind. Aber nicht bei jeder Adresse ist alles vorhanden. Weil mir jetzt aber leider alle informationen untereinander in einer Spalte vorliegen und ich sehr viele adressen habe, brauche ich ein Makro oder eine Excelfunktion, die mir die Adressen automatisch in entsprechende Spalten zuordnet.

z.B.

Spalte A

Mustermann
Max
Musterweg 9
93390 Musterhausen
Tel.: 2222/2222
Fax.: 54456/5458
[email protected]

Musterfrau
Madlen
Musterstraße 12
45564 Musterheim
Tel.: 5555/5555


Am ende soll es so aussehen:

Spalten: Vorname Nachname Straße Ort PLZ .... usw.
Max Mustermann
Madlen Musterfrau usw.

wäre super dankbar, wenn sich hiermit jemand auskennt!

VG
Basti
 
  • #2
Hallo Basti,

nachfolgendes Makro sollte deinen Wunsch erfüllen.

Gruß Matjes :)
Code: 
Sub AdrLinaer_InSpalten()

->Defs Quellblatt
 Const c_SP_A = 1
 Const c_DEF_TEL = Tel.: 
 Const c_DEF_FAX = Fax.: 
 Const c_DEF_MAIL = @
->Defs Zielblatt
 Const c_Z_UEBERSCHRIFT = 1
 Const c_SP_ADR_VORNAME = 1
 Const c_SP_ADR_VORNAME_TXT = Vorname
 Const c_SP_ADR_NACHNAME = 2
 Const c_SP_ADR_NACHNAME_TXT = Nachname
 Const c_SP_ADR_STRASSE = 3
 Const c_SP_ADR_STRASSE_TXT = Straße
 Const c_SP_ADR_ORT = 4
 Const c_SP_ADR_ORT_TXT = Ort
 Const c_SP_ADR_PLZ = 5
 Const c_SP_ADR_PLZ_TXT = PLZ
 Const c_SP_ADR_TEL = 6
 Const c_SP_ADR_TEL_TXT = Telefon
 Const c_SP_ADR_FAX = 7
 Const c_SP_ADR_FAX_TXT = Fax
 Const c_SP_ADR_EMAIL = 8
 Const c_SP_ADR_EMAIL_TXT = eMail

 Dim wb As Workbook, ws As Worksheet, wsz As Worksheet
 Dim x As Long, zq As Long, zz As Long, lAnf As Long, lEnd As Long
 Dim sTxt As String
 Dim bMail As Boolean

->Arbeitsmappe festlegen
 Set wb = ActiveWorkbook
->QuellBlatt festlegen
 Set ws = ActiveSheet
 
->Startzeile feststellen
 lAnf = 0
 For x = 1 To 10
  If ws.Cells(x, c_SP_A).Value <>  Then lAnf = x: Exit For
 Next
 If lAnf = 0 Then MsgBox (Anfang kann in den ersten 10 Zeilen der Spalte A nicht festgestellt werden.): GoTo AUFRAEUMEN

->Letzte Zeile feststellen
 lEnd = ws.Cells(ws.Rows.Count, c_SP_A).End(xlUp).Row
 If lEnd < lAnf + 3 Then MsgBox (Keine vollständige Adresse vorhanden.): GoTo AUFRAEUMEN

->neues Zielblatt anlegen
 Set wsz = wb.Worksheets.Add
->Überschriften eintragen
 zz = c_Z_UEBERSCHRIFT
 wsz.Columns(c_SP_ADR_VORNAME).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_VORNAME).Value = c_SP_ADR_VORNAME_TXT
 wsz.Cells(zz, c_SP_ADR_VORNAME).Font.Bold = True
 wsz.Columns(c_SP_ADR_NACHNAME).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_NACHNAME).Value = c_SP_ADR_NACHNAME_TXT
 wsz.Cells(zz, c_SP_ADR_NACHNAME).Font.Bold = True
 wsz.Columns(c_SP_ADR_STRASSE).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_STRASSE).Value = c_SP_ADR_STRASSE_TXT
 wsz.Cells(zz, c_SP_ADR_STRASSE).Font.Bold = True
 wsz.Columns(c_SP_ADR_ORT).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_ORT).Value = c_SP_ADR_ORT_TXT
 wsz.Cells(zz, c_SP_ADR_ORT).Font.Bold = True
 wsz.Columns(c_SP_ADR_PLZ).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_PLZ).Value = c_SP_ADR_PLZ_TXT
 wsz.Cells(zz, c_SP_ADR_PLZ).Font.Bold = True
 wsz.Columns(c_SP_ADR_TEL).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_TEL).Value = c_SP_ADR_TEL_TXT
 wsz.Cells(zz, c_SP_ADR_TEL).Font.Bold = True
 wsz.Columns(c_SP_ADR_FAX).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_FAX).Value = c_SP_ADR_FAX_TXT
 wsz.Cells(zz, c_SP_ADR_FAX).Font.Bold = True
 wsz.Columns(c_SP_ADR_EMAIL).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_EMAIL).Value = c_SP_ADR_EMAIL_TXT
 wsz.Cells(zz, c_SP_ADR_EMAIL).Font.Bold = True
 
 zq = lAnf
 While (zq < lEnd)
  zz = zz + 1->Zielzeile setzen
  
 ->Muß-Zeilen bearbeiten
 ->1. Nachname
  sTxt = ws.Cells(zq, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_NACHNAME).Value = sTxt
  zq = zq + 1
 ->2. Vorname
  sTxt = ws.Cells(zq, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_VORNAME).Value = sTxt
  zq = zq + 1
 ->3. Straße mit Hausnummer
  sTxt = ws.Cells(zq, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_STRASSE).Value = sTxt
  zq = zq + 1
 ->Ort / PLZ
  sTxt = ws.Cells(zq, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_ORT).Value = Mid(sTxt, 7, Len(sTxt) - 6)
  wsz.Cells(zz, c_SP_ADR_PLZ).Value = Mid(sTxt, 1, 5)
  zq = zq + 1
  
 ->Optionale Zeilen bearbeiten
  While (ws.Cells(zq, c_SP_A).Value <> )
   sTxt = ws.Cells(zq, c_SP_A).Value
   If Mid(sTxt, 1, Len(c_DEF_TEL)) = c_DEF_TEL Then
   ->Telefon
    wsz.Cells(zz, c_SP_ADR_TEL).Value = Mid(sTxt, Len(c_DEF_TEL) + 1, Len(sTxt) - Len(c_DEF_TEL))
   Else
    If Mid(sTxt, 1, Len(c_DEF_FAX)) = c_DEF_FAX Then
    ->Fax
     wsz.Cells(zz, c_SP_ADR_FAX).Value = Mid(sTxt, Len(c_DEF_FAX) + 1, Len(sTxt) - Len(c_DEF_FAX))
    Else
    ->mail-zeile ?
     bMail = False
     For x = 1 To Len(sTxt)
      If Mid(sTxt, x, 1) = c_DEF_MAIL Then bMail = True: Exit For
     Next
     If bMail Then
     ->Mail-Adresse
      wsz.Cells(zz, c_SP_ADR_EMAIL).Value = sTxt
     Else
      ws.Activate
      ws.Cells(zq, c_SP_A).Select
      MsgBox (Zeile  & zq &  kann nicht interpretiert werden.)
      GoTo AUFRAEUMEN
     End If
    End If
   End If
   zq = zq + 1
  Wend
  
  If zq < lEnd Then
  ->Leerzeile(n) überspringen
   While (ws.Cells(zq, c_SP_A).Value = )
    zq = zq + 1
   Wend
  End If
 Wend
 
->Spaltenbreite an Inhalt anpassen
 For x = 1 To wsz.Columns.Count: wsz.Columns(x).AutoFit: Next
AUFRAEUMEN:
 Set wb = Nothing: Set ws = Nothing: Set wsz = Nothing
End Sub
 
  • #3
Ich gehe davon aus, dass das im Word ist, und das Makro für Word gemacht wurde.

Warum öffnest Du diese Datei nicht im Excel?
Da kannst Du die Spalten auswählen und dann bearbeiten.
 
  • #4
Danke Matjes, ich probiers gleich mal aus :)

und nein Renee, das ganze wurde in Excel erstellt, und ich kann die spalten auch bearbeiten, aber bei ca. 600 Adressen ist das eine unendliche Aufgabe...
 
  • #5
Also leider hats nicht funktioniert. ich habe jetzt mal ne beispiel datei als screenshoot hochgeladen und hoff mir kann jemand weiterhelfen. Es ist eine Excel-Datei um die es geht. ich kann die auch gerne per mail verschicken.
 
  • #6
Hallo Basti,

das kann auch nicht funktionieren, da das Beispiel vorgegaukelt hat, dass Name/Vorname immer fest die 1. und 2. Zeile im Block belegen.

Man könnte als Bezugszeile die PLZ/Ort-Zeile hernehmen ( festes Kennzeichen: 5 Ziffern am Anfang der Zeile).
Zeile darüber: Straße/Nr
Zeilen darüber(max. 2 ??): Name1, Name2

feste Kennzeichen für Zeilen nach PLZ/Ort:
am Anfang der Zeile Tel.: -> Telefon
am Anfang der Zeile Fax.: -> Fax
Zeile enthält @ -> email
am Anfang der Zeile -> Internet

Schau mal , ob man damit zurechtkommt.

Gruß Matjes :)
 
  • #7
Jetzt noch das Makro zu den beschriebenen Voraussetzungen.

Gruß Matjes :)
Code: 
Sub AdrLinaer_InSpalten()

->Defs Quellblatt
 Const c_SP_A = 1
 Const c_DEF_TEL = Tel.: 
 Const c_DEF_FAX = Fax.: 
 Const c_DEF_WWW = [url]www.[/url]
 Const c_DEF_MAIL = @
->Defs Zielblatt
 Const c_Z_UEBERSCHRIFT = 1
 Const c_SP_ADR_NAME1 = 1
 Const c_SP_ADR_NAME1_TXT = Firma
 Const c_SP_ADR_NAME2 = 2
 Const c_SP_ADR_NAME2_TXT = Name2
 Const c_SP_ADR_EMAIL = 3
 Const c_SP_ADR_EMAIL_TXT = EMail
 Const c_SP_ADR_FAX = 4
 Const c_SP_ADR_FAX_TXT = Fax:
 Const c_SP_ADR_TEL = 5
 Const c_SP_ADR_TEL_TXT = Tel:
 Const c_SP_ADR_STRASSE = 6
 Const c_SP_ADR_STRASSE_TXT = Straße
 Const c_SP_ADR_PLZ = 7
 Const c_SP_ADR_PLZ_TXT = PLZ
 Const c_SP_ADR_ORT = 8
 Const c_SP_ADR_ORT_TXT = Ort
 Const c_SP_ADR_WWW = 9
 Const c_SP_ADR_WWW_TXT = Homepage

 Dim wb As Workbook, ws As Worksheet, wsz As Worksheet
 Dim x As Long, y As Long, zq As Long, zz As Long, zPLZ As Long, lAnf As Long, lEnd As Long
 Dim sTxt As String, sBuchstabe As String
 Dim bMail As Boolean

->Arbeitsmappe festlegen
 Set wb = ActiveWorkbook
->QuellBlatt festlegen
 Set ws = ActiveSheet
 
->Startzeile feststellen
 lAnf = 0
 For x = 1 To 10
  If ws.Cells(x, c_SP_A).Value <>  Then lAnf = x: Exit For
 Next
 If lAnf = 0 Then MsgBox (Anfang kann in den ersten 10 Zeilen der Spalte A nicht festgestellt werden.): GoTo AUFRAEUMEN

->Letzte Zeile feststellen
 lEnd = ws.Cells(ws.Rows.Count, c_SP_A).End(xlUp).Row
 If lEnd < lAnf + 3 Then MsgBox (Keine vollständige Adresse vorhanden.): GoTo AUFRAEUMEN

->neues Zielblatt anlegen
 Set wsz = wb.Worksheets.Add
->Überschriften eintragen
 zz = c_Z_UEBERSCHRIFT
 wsz.Columns(c_SP_ADR_NAME1).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_NAME1).Value = c_SP_ADR_NAME1_TXT
 wsz.Cells(zz, c_SP_ADR_NAME1).Font.Bold = True
 wsz.Columns(c_SP_ADR_NAME2).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_NAME2).Value = c_SP_ADR_NAME2_TXT
 wsz.Cells(zz, c_SP_ADR_NAME2).Font.Bold = True
 wsz.Columns(c_SP_ADR_STRASSE).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_STRASSE).Value = c_SP_ADR_STRASSE_TXT
 wsz.Cells(zz, c_SP_ADR_STRASSE).Font.Bold = True
 wsz.Columns(c_SP_ADR_ORT).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_ORT).Value = c_SP_ADR_ORT_TXT
 wsz.Cells(zz, c_SP_ADR_ORT).Font.Bold = True
 wsz.Columns(c_SP_ADR_PLZ).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_PLZ).Value = c_SP_ADR_PLZ_TXT
 wsz.Cells(zz, c_SP_ADR_PLZ).Font.Bold = True
 wsz.Columns(c_SP_ADR_TEL).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_TEL).Value = c_SP_ADR_TEL_TXT
 wsz.Cells(zz, c_SP_ADR_TEL).Font.Bold = True
 wsz.Columns(c_SP_ADR_FAX).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_FAX).Value = c_SP_ADR_FAX_TXT
 wsz.Cells(zz, c_SP_ADR_FAX).Font.Bold = True
 wsz.Columns(c_SP_ADR_EMAIL).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_EMAIL).Value = c_SP_ADR_EMAIL_TXT
 wsz.Cells(zz, c_SP_ADR_EMAIL).Font.Bold = True
 wsz.Columns(c_SP_ADR_WWW).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_WWW).Value = c_SP_ADR_WWW_TXT
 wsz.Cells(zz, c_SP_ADR_WWW).Font.Bold = True
 
 zq = lAnf
 While (zq < lEnd)
  zz = zz + 1->Zielzeile setzen
  
 ->PLZ-Zeile feststellen (5 Ziffern am Zeilenanfang, innerhalb 3. bis 5. Zeile im Block)
  zPLZ = 0
  For x = zq + 2 To zq + 5
   sTxt = ws.Cells(x, c_SP_A).Value
   If Len(sTxt) > 5 Then
    For y = 1 To 5
     sBuchstabe = Mid(sTxt, y, 1)
     Select Case sBuchstabe
      Case 0 To 9: If y = 5 Then zPLZ = x
      Case Else: Exit For
     End Select
    Next
   End If
   If (zPLZ <> 0) Then Exit For
  Next
  If zPLZ = 0 Then
   ws.Activate
   ws.Cells(zq, c_SP_A).Select
   MsgBox (Zeile  & zq & : PLZ im Block nicht vorhanden.)
   GoTo AUFRAEUMEN
  End If
  
 ->Muß-Zeilen bearbeiten
 ->Ort / PLZ
  sTxt = ws.Cells(zPLZ, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_ORT).Value = Mid(sTxt, 7, Len(sTxt) - 6)
  wsz.Cells(zz, c_SP_ADR_PLZ).Value = Mid(sTxt, 1, 5)
 ->vorherige Zeile: Straße mit Hausnummer
  sTxt = ws.Cells(zPLZ - 1, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_STRASSE).Value = sTxt
 ->1.Blockzeile: Name1
  sTxt = ws.Cells(zq, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_NAME1).Value = sTxt
 ->ggf. Name2
  If zPLZ - zq > 2 Then
   sTxt = ws.Cells(zq + 1, c_SP_A).Value
   wsz.Cells(zz, c_SP_ADR_NAME2).Value = sTxt
  End If
  
 ->Zeilenzeiger auf Zeile nach PLZ/Ort
  zq = zPLZ + 1
  
 ->Optionale Zeilen bearbeiten
  While (ws.Cells(zq, c_SP_A).Value <> )
   sTxt = ws.Cells(zq, c_SP_A).Value
   If Mid(sTxt, 1, Len(c_DEF_TEL)) = c_DEF_TEL Then
   ->Telefon
    wsz.Cells(zz, c_SP_ADR_TEL).Value = Mid(sTxt, Len(c_DEF_TEL) + 1, Len(sTxt) - Len(c_DEF_TEL))
   Else
    If Mid(sTxt, 1, Len(c_DEF_FAX)) = c_DEF_FAX Then
    ->Fax
     wsz.Cells(zz, c_SP_ADR_FAX).Value = Mid(sTxt, Len(c_DEF_FAX) + 1, Len(sTxt) - Len(c_DEF_FAX))
    Else
     If Mid(sTxt, 1, Len(c_DEF_WWW)) = c_DEF_WWW Then
     ->Homepage
      wsz.Cells(zz, c_SP_ADR_WWW).Value = sTxt
     Else
     ->mail-zeile ?
      bMail = False
      For x = 1 To Len(sTxt)
       If Mid(sTxt, x, 1) = c_DEF_MAIL Then bMail = True: Exit For
      Next
      If bMail Then
      ->Mail-Adresse
       wsz.Cells(zz, c_SP_ADR_EMAIL).Value = sTxt
      Else
       ws.Activate
       ws.Cells(zq, c_SP_A).Select
       MsgBox (Zeile  & zq &  kann nicht interpretiert werden.)
       GoTo AUFRAEUMEN
      End If
     End If
    End If
   End If
   zq = zq + 1
  Wend
  
  If zq < lEnd Then
  ->Leerzeile(n) überspringen
   While (ws.Cells(zq, c_SP_A).Value = )
    zq = zq + 1
   Wend
  End If
 Wend
 
->Spaltenbreite an Inhalt anpassen
 For x = 1 To wsz.Columns.Count: wsz.Columns(x).AutoFit: Next
AUFRAEUMEN:
 Set wb = Nothing: Set ws = Nothing: Set wsz = Nothing
End Sub
 
  • #8
im Excel importieren, nicht öffnen. Dann kannst Du die Spalten auswählen und Excel trennt es ganz von selbst.

Vielleicht solltest Du die Excel Datei einmal hochladen.
 
  • #9
Ich hab das Makro ausprobiert, aber irgendwie bekomm ich das nicht hin...

Die Excel-Datei kann ich leider nicht hocladen, weil sie nicht zu den erlaubten Dateitypen gehört... ich kann sie dir aber gern Mailen
 
  • #10
Schau mal in deine PM - und schick sie mir mal.

Gruß Matjes :)
 
  • #11
Hallo Basti

Ich habe festgestellt, dass es Adressen mit 8 Zeilen, aber auch solche mit 10-11 Zeilen gibt.
Ich denke, dass das in etwa das grösste Problem darstellt.

Denn die Adressen in Spalten umzusetzen, konnte ich relativ einfach lösen, aber danach?
Melde mich wieder...........
 
  • #12
Also ich hab jetzt 2 Dateien von Basti in der Hand. Auf die erste Datei hat das Makro schon gepasst. Hab noch die Fehlerbehandlung und die Spaltennummern angepasst und schwubdiewub war die erste Datei fertig. ;D

Bei der 2. Datei ist die Problemstellung größer: Adressen aus verschiedenen Ländern :mad: ganz unterschiedliche Formate :mad: Einziger Lichtblick: in den Blöcken steht auch das Land. Also länderabhängige Blockbearbeitung ??? mal schauen ...

Gruß Matjes :)

Makro zur 1.Datei:
Code: 
Sub AdrLinaer_InSpalten()

->Defs Quellblatt
 Const c_SP_A = 1
 Const c_DEF_TEL = Tel.: 
 Const c_DEF_FAX = Fax.: 
 Const c_DEF_WWW = [url]www.[/url]
 Const c_DEF_MAIL = @
->Defs Zielblatt
 Const c_Z_UEBERSCHRIFT = 1
 Const c_SP_ADR_NAME1 = 4
 Const c_SP_ADR_NAME1_TXT = Firma
 Const c_SP_ADR_NAME2 = c_SP_ADR_NAME1 + 1
 Const c_SP_ADR_NAME2_TXT = Name2
 Const c_SP_ADR_EMAIL = 11
 Const c_SP_ADR_EMAIL_TXT = EMail
 Const c_SP_ADR_FAX = c_SP_ADR_EMAIL + 1
 Const c_SP_ADR_FAX_TXT = Fax:
 Const c_SP_ADR_TEL = c_SP_ADR_FAX + 1
 Const c_SP_ADR_TEL_TXT = Tel:
 Const c_SP_ADR_STRASSE = c_SP_ADR_TEL + 1
 Const c_SP_ADR_STRASSE_TXT = Straße
 Const c_SP_ADR_PLZ = c_SP_ADR_STRASSE + 1
 Const c_SP_ADR_PLZ_TXT = PLZ
 Const c_SP_ADR_ORT = c_SP_ADR_PLZ + 1
 Const c_SP_ADR_ORT_TXT = Ort
 Const c_SP_ADR_WWW = c_SP_ADR_ORT + 3
 Const c_SP_ADR_WWW_TXT = Homepage

 Dim wb As Workbook, ws As Worksheet, wsz As Worksheet
 Dim x As Long, y As Long, zq As Long, zz As Long, zPLZ As Long, lAnf As Long, lEnd As Long
 Dim sTxt As String, sBuchstabe As String
 Dim bMail As Boolean

->Arbeitsmappe festlegen
 Set wb = ActiveWorkbook
->QuellBlatt festlegen
 Set ws = ActiveSheet
 
->Startzeile feststellen
 lAnf = 0
 For x = 1 To 10
  If ws.Cells(x, c_SP_A).Value <>  Then lAnf = x: Exit For
 Next
 If lAnf = 0 Then MsgBox (Anfang kann in den ersten 10 Zeilen der Spalte A nicht festgestellt werden.): GoTo AUFRAEUMEN

->Letzte Zeile feststellen
 lEnd = ws.Cells(ws.Rows.Count, c_SP_A).End(xlUp).Row
 If lEnd < lAnf + 3 Then MsgBox (Keine vollständige Adresse vorhanden.): GoTo AUFRAEUMEN

->neues Zielblatt anlegen
 Set wsz = wb.Worksheets.Add
->Überschriften eintragen
 zz = c_Z_UEBERSCHRIFT
 wsz.Columns(c_SP_ADR_NAME1).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_NAME1).Value = c_SP_ADR_NAME1_TXT
 wsz.Cells(zz, c_SP_ADR_NAME1).Font.Bold = True
 wsz.Columns(c_SP_ADR_NAME2).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_NAME2).Value = c_SP_ADR_NAME2_TXT
 wsz.Cells(zz, c_SP_ADR_NAME2).Font.Bold = True
 wsz.Columns(c_SP_ADR_STRASSE).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_STRASSE).Value = c_SP_ADR_STRASSE_TXT
 wsz.Cells(zz, c_SP_ADR_STRASSE).Font.Bold = True
 wsz.Columns(c_SP_ADR_ORT).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_ORT).Value = c_SP_ADR_ORT_TXT
 wsz.Cells(zz, c_SP_ADR_ORT).Font.Bold = True
 wsz.Columns(c_SP_ADR_PLZ).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_PLZ).Value = c_SP_ADR_PLZ_TXT
 wsz.Cells(zz, c_SP_ADR_PLZ).Font.Bold = True
 wsz.Columns(c_SP_ADR_TEL).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_TEL).Value = c_SP_ADR_TEL_TXT
 wsz.Cells(zz, c_SP_ADR_TEL).Font.Bold = True
 wsz.Columns(c_SP_ADR_FAX).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_FAX).Value = c_SP_ADR_FAX_TXT
 wsz.Cells(zz, c_SP_ADR_FAX).Font.Bold = True
 wsz.Columns(c_SP_ADR_EMAIL).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_EMAIL).Value = c_SP_ADR_EMAIL_TXT
 wsz.Cells(zz, c_SP_ADR_EMAIL).Font.Bold = True
 wsz.Columns(c_SP_ADR_WWW).NumberFormat = @
 wsz.Cells(zz, c_SP_ADR_WWW).Value = c_SP_ADR_WWW_TXT
 wsz.Cells(zz, c_SP_ADR_WWW).Font.Bold = True
 
 zq = lAnf
 While (zq < lEnd)
  zz = zz + 1->Zielzeile setzen
  
 ->PLZ-Zeile feststellen (5 Ziffern am Zeilenanfang, innerhalb 3. bis 5. Zeile im Block)
  zPLZ = 0
  For x = zq + 2 To zq + 5
   sTxt = ws.Cells(x, c_SP_A).Value
   If Len(sTxt) > 5 Then
    For y = 1 To 5
     sBuchstabe = Mid(sTxt, y, 1)
     Select Case sBuchstabe
      Case 0 To 9: If y = 5 Then zPLZ = x
      Case Else: Exit For
     End Select
    Next
   End If
   If (zPLZ <> 0) Then Exit For
  Next
  If zPLZ = 0 Then
   Application.DisplayAlerts = False: wsz.Delete: Application.DisplayAlerts = True
   ws.Activate
   ws.Cells(zq, c_SP_A).Select
   MsgBox (Zeile  & zq & : PLZ im Block nicht vorhanden.)
   GoTo AUFRAEUMEN
  End If
  
 ->Muß-Zeilen bearbeiten
 ->Ort / PLZ
  sTxt = ws.Cells(zPLZ, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_ORT).Value = Mid(sTxt, 7, Len(sTxt) - 6)
  wsz.Cells(zz, c_SP_ADR_PLZ).Value = Mid(sTxt, 1, 5)
 ->vorherige Zeile: Straße mit Hausnummer
  sTxt = ws.Cells(zPLZ - 1, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_STRASSE).Value = sTxt
 ->1.Blockzeile: Name1
  sTxt = ws.Cells(zq, c_SP_A).Value
  wsz.Cells(zz, c_SP_ADR_NAME1).Value = sTxt
 ->ggf. Name2
  If zPLZ - zq > 2 Then
   sTxt = ws.Cells(zq + 1, c_SP_A).Value
   wsz.Cells(zz, c_SP_ADR_NAME2).Value = sTxt
  End If
  If zPLZ - zq > 3 Then
   Application.DisplayAlerts = False: wsz.Delete: Application.DisplayAlerts = True
   ws.Activate
   ws.Cells(zq, c_SP_A).Select
   MsgBox (Zeile:  & zq &  - zuviele Namensszeilen:  & (zPLZ - zq - 1) &  max. 3)
   GoTo AUFRAEUMEN
  End If
  
  
 ->Zeilenzeiger auf Zeile nach PLZ/Ort
  zq = zPLZ + 1
  
 ->Optionale Zeilen bearbeiten
  While (ws.Cells(zq, c_SP_A).Value <> )
   sTxt = ws.Cells(zq, c_SP_A).Value
   If Mid(sTxt, 1, Len(c_DEF_TEL)) = c_DEF_TEL Then
   ->Telefon
    wsz.Cells(zz, c_SP_ADR_TEL).Value = Mid(sTxt, Len(c_DEF_TEL) + 1, Len(sTxt) - Len(c_DEF_TEL))
   Else
    If Mid(sTxt, 1, Len(c_DEF_FAX)) = c_DEF_FAX Then
    ->Fax
     wsz.Cells(zz, c_SP_ADR_FAX).Value = Mid(sTxt, Len(c_DEF_FAX) + 1, Len(sTxt) - Len(c_DEF_FAX))
    Else
     If Mid(sTxt, 1, Len(c_DEF_WWW)) = c_DEF_WWW Then
     ->Homepage
      wsz.Cells(zz, c_SP_ADR_WWW).Value = sTxt
     Else
     ->mail-zeile ?
      bMail = False
      For x = 1 To Len(sTxt)
       If Mid(sTxt, x, 1) = c_DEF_MAIL Then bMail = True: Exit For
      Next
      If bMail Then
      ->Mail-Adresse
       wsz.Cells(zz, c_SP_ADR_EMAIL).Value = sTxt
      Else
       Application.DisplayAlerts = False: wsz.Delete: Application.DisplayAlerts = True
       ws.Activate
       ws.Cells(zq, c_SP_A).Select
       MsgBox (Zeile  & zq &  kann nicht interpretiert werden.)
       GoTo AUFRAEUMEN
      End If
     End If
    End If
   End If
   zq = zq + 1
  Wend
  
  If zq < lEnd Then
  ->Leerzeile(n) überspringen
   While (ws.Cells(zq, c_SP_A).Value = )
    zq = zq + 1
   Wend
  End If
 Wend
 
->Spaltenbreite an Inhalt anpassen
 For x = 1 To wsz.Columns.Count: wsz.Columns(x).AutoFit: Next
AUFRAEUMEN:
 Set wb = Nothing: Set ws = Nothing: Set wsz = Nothing
End Sub
 
Thema:

Zellen je nach Inhalt automatisch in richtige Spalte verschieben

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.840
Beiträge
707.963
Mitglieder
51.494
Neuestes Mitglied
Flensburg45
Oben