Macro um ein Workbook zu sortieren

[elgato2000]

Hallo an alle

Ich versuche ein Macro zu generieren, dass mir eine Mappe aufräumt, bzw. richtig sortiert.

Anbei zwei xls Dateien, Before.xls und After.xls. Sinngemäß soll das Macro Before.xls so sortieren, dass es aussieht wie After.xls

Vielen Dank für Eure Hilfe !

[Crazy Tom]

Hallo

und was hat das mit sortieren zu tun?
in der Datei "After" sind doch nur die Leerzellen wech

btw hast du die Leute in der Liste gefragt ob sie mit Adresse und Tel-Nummer
sowie Email im Internet veröffentlicht werden wollen?

MfG Tom

[elgato2000]

Hallo

und was hat das mit sortieren zu tun?
in der Datei "After" sind doch nur die Leerzellen wech

btw hast du die Leute in der Liste gefragt ob sie mit Adresse und Tel-Nummer
sowie Email im Internet veröffentlicht werden wollen?

MfG Tom

Danke für den hinweis Tom, ich habe irrtümlicherweise "echte Daten" angehängt. Moderator möchte die Anhänge bitte löschen

[elgato2000]

Danke für den hinweis Tom, ich habe irrtümlicherweise "echte Daten" angehängt. Moderator möchte die Anhänge bitte löschen

Wenn Du genau hingeschaut hast, lag das Problem tiefer und nicht nur in leeren Zellen.

[atilla]

Hallo,

Deine Beharrlichkeit zahlt sich aus, denke ich:

Code:

Sub mach_mal()
 Dim i As Long, j As Long, jj As Long
 Dim lngZ As Long
 lngZ = Cells(Rows.Count, 2).End(xlUp).Row
 For i = 2 To lngZ - 1
   If Cells(i, 2) = "" Then
     Do
       j = j + 1
     Loop Until Cells(i + j, 2) <> "" And j <= lngZ
       For jj = 1 To j - 1
         Cells(i + jj - 1, 2) = Cells(i - 1, 2) & " " & jj + 1
         Cells(i + jj - 1, 4) = Cells(i - 1, 4).Value
         Range(Cells(i - 1, 6), Cells(i + jj - 1, 6)) = Range(Cells(i, 6), Cells(i + jj, 6)).Value
       Next jj
   End If
   j = 0
 Next i
 
 Range("B2:B" & lngZ).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 For i = 2 To lngZ
   jj = Application.CountIf(Range("B2:B" & i), Cells(i, 2))
   If jj > 1 Then
     Cells(i, 2) = Cells(i - 1, 2) & " " & jj
   End If
 Next i
End Sub

[elgato2000]

Hallo Atilla !


Fast perfekt. Du bist echt ne Wucht.

Aaaaaaaaaber:

irgendwas stimmt nicht.

Angehängter file, schau mal. Und pack mal deinen Code darein.

[atilla]

Hallo,

machen wir anders. Sag was nicht stimmt. Ich such jetzt nicht rum.

[elgato2000]

Ok klar.

z.B. Yvonn Hell

Die gute Dame hat bestellt:

Greenspace 1P Weltall
Universum 4LP Weltraum Space
New Sunset Sonnenuntergang Natur Meer Sonne Pano

Daher muss das auch so in den Zeilen stehen, ohne Leerzelle in Spalte F

Wenn ich dein Macro laufen lass, steht da dann aber andere Namen

[atilla]

Hallo,

ok, hab's gerade auch gesehen.

Teste mal:

Code:

Sub mach_mal()
 Dim i As Long, j As Long, jj As Long
 Dim lngZ As Long
 lngZ = Cells(Rows.Count, 2).End(xlUp).Row
 For i = 2 To lngZ - 1
   If Cells(i, 2) = "" Then
     Do
       j = j + 1
     Loop Until Cells(i + j, 2) <> "" And j <= lngZ
       For jj = 1 To j - 1
         Cells(i + jj - 1, 2) = Cells(i - 1, 2) & " " & jj + 1
         Cells(i + jj - 1, 4) = Cells(i - 1, 4).Value
       Next jj
       Range(Cells(i - 1, 6), Cells(i + jj - 2, 6)) = Range(Cells(i, 6), Cells(i + jj - 1, 6)).Value
   End If
   j = 0
 Next i
 
 Range("B2:B" & lngZ).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 For i = 2 To lngZ
   jj = Application.CountIf(Range("B2:B" & i), Cells(i, 2))
   If jj > 1 Then
     Cells(i, 2) = Cells(i - 1, 2) & " " & jj
   End If
 Next i
End Sub

[elgato2000]

siehe Anlage, nachdem das Macro gelaufen ist