Zellen je nach Inhalt automatisch in richtige Spalte verschieben

Dieses Thema Zellen je nach Inhalt automatisch in richtige Spalte verschieben im Forum "Microsoft Office Suite" wurde erstellt von Basti.Basti, 15. Juli 2013.

Thema: Zellen je nach Inhalt automatisch in richtige Spalte verschieben Hallo Zusammen, ich habe eine wichtige Frage. Mir liegt eine Liste von Adressen vor, bei der Namen, Telefonnummer,...

  1. 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
    andreas.Huber@web.de

    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 www. -> 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 :)
     
Die Seite wird geladen...

Zellen je nach Inhalt automatisch in richtige Spalte verschieben - Ähnliche Themen

Forum Datum
Zellen nach Eingabe automatisch schützen Microsoft Office Suite 24. Nov. 2010
Excel: Hintergrund von Zellen täglich um 1 Zeile nach unten verschieben Microsoft Office Suite 17. Feb. 2009
Drucken nach Zellenabfrage Microsoft Office Suite 25. März 2008
Tabellenauswertung nach mehreren Zellen Microsoft Office Suite 31. Jan. 2007
excel: Zellen ausblenden wenn nächstes monat Windows XP Forum 21. Juni 2006