Supportnet / Forum / Tabellenkalkulation

Hallo die Experten, ich hab mal wieder eine Excel-Aufgabe, die ich nicht gebacken bekomme. In meiner Adressen-Liste stehen alle Angaben schön sortiert in einer Spalte übereinander. Jede Adresse hat ihren eigenen Schlüssel. Schaut so aus: 1 Name 1 Strasse 1 Ort 2 Name 2 Strasse 2 Ort 2 Tel Die Tabellen sollen so umgestellt werden, dass die einzelnen Daten-Sätze (Adressen) untereinander stehen bleiben. Die einzelnen Angaben (Name, Straße, Tel, etc.) sollen genau in der Reihenfolge wie sie jetzt untereinander stehen, nebeneinander liegen. Die Nummer soll als Schlüssel in der ersten Spalte stehen bleiben. Soll so aussehen: 1 Name Strasse Ort 2 Name Strasse Ort Tel Vielen Dank für die Unterstützung!! Huxtbl

hi huxbl :)

wie gewünscht :))

Tabelle2 dient der neuordnug

gruss nighty

Option Explicit
Sub makro01()
Dim suche1 As Range
Dim suche2 As Range
Dim zaehler1 As Long
Dim zaehler2 As Long
Dim zaehler3 As Long
Dim zaehler4 As Long
With Worksheets(1)
zaehler1 = 1
Do
Set suche1 = .Range("A" & zaehler1 & ":A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find("name", LookIn:=xlValues)
If Not suche1 Is Nothing Then
Set suche2 = .Range("A" & (suche1.Row + 1) & ":A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find("name", LookIn:=xlValues)
If Not suche2 Is Nothing Then
zaehler1 = suche2.Row - 1
zaehler3 = 1
zaehler4 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
For zaehler2 = suche1.Row To suche2.Row - 1
Sheets(2).Cells(zaehler4, zaehler3) = .Range("B" & zaehler2)
zaehler3 = zaehler3 + 1
Next zaehler2
Else
zaehler3 = 1
zaehler4 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
For zaehler2 = suche1.Row To .UsedRange.SpecialCells(xlCellTypeLastCell).Row
Sheets(2).Cells(zaehler4, zaehler3) = .Range("B" & zaehler2)
zaehler3 = zaehler3 + 1
Next zaehler2
Exit Do
End If
End If
Loop
End With
End Sub

hi huxbl :)

noch zu erwähnen wäre das das findschlüsselwort zur zeit "name" ist,gegebenenfalls anzupassen wäre :))

gruss nighty

hi all :)

nochmal zum besseren anpassen vielleicht :(

gruss nighty

Option Explicit
Sub makro01()
Dim suche1 As Range
Dim suche2 As Range
Dim zaehler1 As Long
Dim zaehler2 As Long
Dim zaehler3 As Long
Dim zaehler4 As Long
With Worksheets(1)
zaehler1 = 1
Do

Rem beide suchbegriffe der find methoden sollten
identisch sein für die satz bzw spaltentrennung ,gesucht wird in sheets(1)/spalte a nach zur zeit "name" ,die ausgabe erfolgt sheets(2)

Rem die vorteile der findmethode gegenüber einer durchgehenden schleife ermöglichen ein blockweises springen was eine schnelle arbeitsgeschwindigkeit mit sich bringt

Rem in dieser zeile bei der ersten find methode
Rem "name" gegegebenenfalls ändern

Set suche1 = .Range("A" & zaehler1 & ":A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find("name", LookIn:=xlValues)
If Not suche1 Is Nothing Then

Rem in dieser zeile bei der zweiten find methode
Rem "name" gegegebenenfalls ändern

Set suche2 = .Range("A" & (suche1.Row + 1) & ":A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find("name", LookIn:=xlValues)
If Not suche2 Is Nothing Then
zaehler1 = suche2.Row - 1
zaehler3 = 1
zaehler4 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
For zaehler2 = suche1.Row To suche2.Row - 1
Sheets(2).Cells(zaehler4, zaehler3) = .Range("B" & zaehler2)
zaehler3 = zaehler3 + 1
Next zaehler2
Else
zaehler3 = 1
zaehler4 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
For zaehler2 = suche1.Row To .UsedRange.SpecialCells(xlCellTypeLastCell).Row
Sheets(2).Cells(zaehler4, zaehler3) = .Range("B" & zaehler2)
zaehler3 = zaehler3 + 1
Next zaehler2
Exit Do
End If
End If
Loop
End With
End Sub

Hallo Nighty,

vielen Dank für Deine Mühe!

Ich habe die erste Nachricht eingebaut. Es hat sich aufgehängt.

Mit Makros kenn ich mich leider nicht gut aus. Bei Deiner dritten Nachricht habe ich "leichte" Verständnisprobleme.

Viele Grüße,

Huxtbl

hi Huxtbl :))

:)

gruss nighty

rem erzwungene deklaration von variablen

Option Explicit

rem name des makros

Sub makro01()

rem deklaration von variablen

rem als range objekt

Dim suche1 As Range
Dim suche2 As Range

rem deklaration als varialen als lange zahl

Dim zaehler1 As Long
Dim zaehler2 As Long
Dim zaehler3 As Long
Dim zaehler4 As Long

rem vereinfacht den zugriff auf sheet(1) bzw. alle befehle mit vorrausgesetzten punkt beziehen sich darauf

With Worksheets(1)

rem zeilenzaehler
zaehler1 = 1

rem anfang einer endlosschleife
Do

rem ueber die erste findmethode wird in spalte a nach "name" gesucht und dessen pos bei fund festgehalten,mit der 2 findmethode der naechste "name" in spalte a gesucht,bei fund diesmal 1 abgezogen,somit du jetzt einen bereich von-bis hast,
diese beiden werte werden einer wiederholungschleife uebergeben und einzeln dann die spalten hochgezaehlt bzw gefuellt,sollte die 2 findmethode nichts finden wird die do loop schleife verlassen und der letzte block gefuellt und das makro beendet

rem erste objekt mit der findmethode
rem achte auf den vorrangestellten punkt

Set suche1 = .Range("A" & zaehler1 & ":A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find("name", LookIn:=xlValues)

rem abfrage der 1 findmethode auf fund

If Not suche1 Is Nothing Then

rem 2 findmethode

Set suche2 = .Range("A" & (suche1.Row + 1) & ":A" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Find("name", LookIn:=xlValues)

rem abfrage der 2 findmethode auf fund

If Not suche2 Is Nothing Then

rem pos der 2 findmethode mit 1 auf abzug

zaehler1 = suche2.Row - 1

rem spaltenanfang von sheet(2)

zaehler3 = 1

rem erfassung der letzten zeile von sheet(2)

zaehler4 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

rem wiederholungsschleife um einen block auszulesen bzw von sheet(2) spalten fuellen

For zaehler2 = suche1.Row To suche2.Row - 1

rem spalten fuellen

Sheets(2).Cells(zaehler4, zaehler3) = .Range("B" & zaehler2)

rem spaltenzaehler

zaehler3 = zaehler3 + 1

rem ende eines schleifenduchlaufes

Next zaehler2

rem nicht fund der 2 findmethode bzw verzweigung

Else

rem spaltenzaehler

zaehler3 = 1

rem erfassung der letzten zeile von sheet(2)

zaehler4 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

rem wiederholungsschleife um einen block auszulesen bzw von sheet(2) spalten fuellen

For zaehler2 = suche1.Row To .UsedRange.SpecialCells(xlCellTypeLastCell).Row

rem spalten fuellen

Sheets(2).Cells(zaehler4, zaehler3) = .Range("B" & zaehler2)

rem spaltenzaehler

zaehler3 = zaehler3 + 1

rem ende eines schleifenduchlaufes

Next zaehler2

rem raussprund der endlosschleife bei nichtfund der 2 findmethode

Exit Do

rem ende der ersten fundabfrage

End If

rem ende der zweiten fundabfrage

End If

rem ruecklauf der endlosschleife

Loop

rem with siehe auch oben bzw with/end with

End With

rem ende des malros

End Sub

rem es sollten keine geschuetzten bereiche wie verbundene zellen vorliegen
rem zur zeit ist bei beiden find methoden als suchbegriff "name" angegeben wenn es bei dir so aussieht "Name" ist dies auch zu aendern bei beiden

• Junk-E-Mail-Listen sind voll
• MSN-Virus nicht löschbare MRU-Listen
• mehrere Listen zusammenfassen
• Listen symbol in einer Zelle (Excel) soll immer gezeigt bleiben