Tabellendaten verschieben

Hallo,
ich möchte in einer Tabelle die Daten von zwei Spalten neu organisieren. Die Tabelle hat folgende Struktur:
A;[leer];Name1
A;Name2;[leer] ;
A;[leer];Name3
B;[leer];Name4
B;Name5;[leer]
A;Name6;[leer]
In der Spalte 1 befindet sich ein Zeichencode. Ansonsten befindet sich in den Spalten B und C pro Zeile jeweils ein Name in einer Zelle (entweder in B oder C). Die anderen Zellen sind leer.
Ich möchte nun mittels eines Makros spaltenweise die Namen nach oben verschieben. Dieses darf allerdings nur geschehen, wenn der Zeichencode in der Spalte 1 übereinstimmt. Außerdem darf die Reihenfolge in der Spalte 1 nicht verändert werden und die namen zwischen den Spalten dürfen nicht getauscht werden. Ein sortieren kommt also nicht in Frage.
Die Tabelle sollte nach der Bearbeitung folgendermaßen aussehen. Eventuelle Formatierungen müssen mit übernommen werden.
A;Name2;Name1
A;Name6;Name3
A;[leer];[leer]
B;Name5;Name4
B;[leer];[leer]
A;[leer];[leer]
Ziel ist es, die Namen möglichst weit Spaltenweise nach oben zu verschieben und zwar an die erste freie Stelle, an der der zeichencode übereinstimmt.
Da die Daten zusätzlich weiterbearbeitet werden müssen, kommt ein Ansatz mittels Matrixformeln nicht in Frage.
Ich wäre für eure Hilfe sehr dankbar.
Gruß
Rainer

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub schreib() Dim t As Long For t = LBound(ArrA()) To UBound(ArrA()) Cells(ArrZeileA(t), 1) = ArrA(t) Cells(ArrZeileA(t), 2) = ArrSp1Neu(t) Cells(ArrZeileA(t), 3) = ArrSp2neu(t) Next t For t = LBound(ArrB()) To UBound(ArrB()) Cells(ArrZeileB(t), 1) = ArrB(t) Cells(ArrZeileB(t), 2) = ArrSp1NeuB(t) Cells(ArrZeileB(t), 3) = ArrSp2neuB(t) Next t End Sub

Option Explicit Sub Reorg() Dim lngZ As Long, zz As Long, strC As String, ss As Long, zL As Long Const spH As Long = 5 ' Nummer der (leeren) Hilfsspalte - anpassen ' (hinter der letzten gefüllten Spalte) lngZ = Cells(Rows.Count, 1).End(xlUp).Row With Range(Cells(1, spH), Cells(lngZ, spH)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(lngZ, spH)).Sort _ Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom For ss = 2 To 3 zz = 1 While zz

Sub ReorgU() Dim lngZ As Long, zz As Long, strC As String, ss As Long, zL As Long Const spH As Long = 6 ' Nummer der (leeren) Hilfsspalte - anpassen ' (hinter der letzten gefüllten Spalte) lngZ = Cells(Rows.Count, 1).End(xlUp).Row With Range(Cells(1, spH), Cells(lngZ, spH)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(lngZ, spH)).Sort _ Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom For ss = 2 To 3 zz = 2 While zz

Option Explicit Sub ReorgUD() Dim lngZ As Long, zz As Long, strC As String, ss As Long, zL As Long, varZ Const blnL As Boolean = False ' "Leere" Zeilen löschen? Const spH As Long = 4 ' Nummer der (leeren) Hilfsspalte - anpassen ' (hinter der letzten gefüllten Spalte) lngZ = Cells(Rows.Count, 1).End(xlUp).Row With Range(Cells(1, spH), Cells(lngZ, spH)) .Formula = "=ROW()" .Value = .Value End With Range(Cells(1, 1), Cells(lngZ, spH)).Sort _ Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom For ss = 2 To 3 zz = 2 While zz

Hi Rainer,
hier kannst du die relevanten Spalten leicht vorgeben. Jetzt gibt es vier Möglichkeiten,
mit den "leeren" Zeilen umzugehen. Habe ich damit etwas getroffen, was du mit "Gliederung" gemeint hast?
Viel Spaß mit


Sub ReorgUDS()
Dim lngZ As Long, zz As Long, strC As String, ss As Long, zL As Long, varZ
Const spV As Long = 2         ' Nummer ersten  "Verschiebe"-Spalte
Const spB As Long = 7         ' Nummer letzten "Verschiebe"-Spalte
Const spH As Long = 8         ' Nummer der (leeren) Hilfsspalte - anpassen
'   (hinter der letzten gefüllten Spalte)
Const intL As Integer = 0     ' Umgang mit "leeren" Zeilen
'    0: stehen lassen
'    1: an den Anfang sortieren
'    2: an das Ende   sortieren
'    3: löschen
Sheets(1).Select                                                     ' #TEST
Sheets(2).Range("A1:E35").Copy Cells(1, 1)                           ' #TEST
lngZ = Cells(Rows.Count, 1).End(xlUp).Row
With Range(Cells(1, spH), Cells(lngZ, spH))
.Formula = "=ROW()"
.Value = .Value
End With
Range(Cells(1, 1), Cells(lngZ, spH)).Sort _
Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For ss = spV To spB
zz = 2
While zz  0)       ' spez. Sort leerer Zeilen - nur bei intL > 0
For ss = spV To spB
If Len(Cells(zz, ss)) > 0 Then Exit For
Next ss
If ss > spB Then Cells(zz, spH) = IIf(intL = 1, -2, 1) * lngZ + zz
Next zz
Range(Cells(1, 1), Cells(lngZ, spH)).Sort _
Key1:=Cells(2, spH), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
If intL = 3 Then                       ' Löschen leerer Zeilen - nur bei intL = 3
varZ = Application.Match(lngZ + 1, Columns(spH), 1)
If IsNumeric(varZ) Then
If Cells(varZ, spH)  lngZ Then Range(Rows(varZ), Rows(lngZ)).Delete
End If
End If
'   Columns(spH).Clear
End Sub

Rückmeldung wäre nett! - Erich aus Kamp-Lintfort wünscht dir fröhliche Feiertage!

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread