Hi Robert,
hier noch eine Variante, etwas aufgeräumter und universeller einsetzbar:
Option Explicit
Sub UmSort()
Dim lngQ As Long, arrQ, arrW(), arrK() As String, qq As Long, nn As Long
Dim arS, cc As Long, strK As String, ii As Long, zz As Long, arrZ()
With Sheets("Tabelle1")
lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row
arrQ = .Cells(1, 1).Resize(lngQ, 8) ' Quelldaten
End With
ReDim arrW(1 To 9, 1 To lngQ) ' Array für Werte
ReDim arrK(1 To lngQ) ' Array für Keys
For qq = 2 To lngQ ' Schleife über Quellzeilen
For nn = 6 To 8 ' Schleife über Funktionen
arS = Split(arrQ(qq, nn), ", ") ' Namen extrahieren
For cc = 0 To UBound(arS) ' Schleife über Namen
' Key zum Vergleich
strK = arS(cc) & "#" & arrQ(qq, 1) & "#" & arrQ(qq, 2) & "#" & _
arrQ(qq, 3) & "#" & arrQ(qq, 4) & "#" & arrQ(qq, 5)
For ii = 1 To zz
If strK = arrK(ii) Then ' wenn Key schon da
arrW(nn - 4, ii) = "x" ' nur neue Funktion
Exit For
End If
Next ii
If ii > zz Then ' neuer Key
zz = zz + 1 ' neue Zeile
If zz > UBound(arrW, 2) Then ' evtl. Arrays vergrößern
ReDim Preserve arrW(1 To 9, 1 To 2 * UBound(arrW, 2))
ReDim Preserve arrK(1 To UBound(arrW, 2))
End If
arrK(zz) = strK ' Key merken
arrW(1, zz) = arS(cc) ' Werte eintragen
arrW(nn - 4, zz) = "x" ' Funktion
arrW(5, zz) = arrQ(qq, 2)
arrW(6, zz) = arrQ(qq, 3)
arrW(7, zz) = arrQ(qq, 4)
arrW(8, zz) = arrQ(qq, 5)
arrW(9, zz) = arrQ(qq, 1)
End If
Next cc
Next nn
Next qq
GrupSort arrW, arrZ, 1, 0, 1
' Ausgabe in neues Blatt
With ActiveWorkbook.Worksheets.Add(after:=ActiveWorkbook.Worksheets("Tabelle1"))
.Rows(1).HorizontalAlignment = xlCenter
.Columns("B:D").HorizontalAlignment = xlCenter
.Cells(1, 1).Resize(, 9) = _
Split("Name Arbeiter Polier Leiter Bereich Land Region Subregion Kreis")
.Cells(2, 1).Resize(zz, 9) = arrZ
.Columns("A:I").AutoFit
End With
End Sub
Sub GrupSort(arrA(), arrB(), lngK As Long, blnDup As Boolean, blnTra As Boolean)
' Quelle Ziel Key-Zeile mehrf. Ausgabe? Transponieren?
Dim arrN() As Long, nn As Long, qq As Long, cc As Long, ii As Long
ReDim arrN(LBound(arrA, 2) To UBound(arrA, 2), 1)
ReDim arrB(LBound(arrA, 1 - blnTra) To UBound(arrA, 1 - blnTra), _
LBound(arrA, 2 + blnTra) To UBound(arrA, 2 + blnTra))
For qq = LBound(arrA, 2) To UBound(arrA, 2)
For ii = qq - 1 To 1 Step -1
If arrA(lngK, ii) = arrA(lngK, qq) Then ' wenn Key schon da
arrN(ii, 1) = qq ' merke Nachfolgerzeile
arrN(qq, 0) = 1 ' merke "ist Nachfolger"
Exit For
End If
Next ii
Next qq
For qq = LBound(arrA, 2) To UBound(arrA, 2)
If arrN(qq, 0) = 0 Then ' wenn "ist kein Nachfolger"
nn = nn + 1 ' gib Satz aus
For cc = LBound(arrA) To UBound(arrA)
If blnTra Then arrB(nn, cc) = arrA(cc, qq) Else arrB(cc, nn) = arrA(cc, qq)
Next cc
ii = arrN(qq, 1) ' 1. Nachfolger
While ii > 0 ' Schleife über die Nachfolger
nn = nn + 1 ' gib Satz aus
For cc = LBound(arrA) To UBound(arrA)
If blnDup Or cc lngK Then
If blnTra Then arrB(nn, cc) = arrA(cc, ii) Else arrB(cc, nn) = arrA(cc, ii)
End If
Next cc
ii = arrN(ii, 1)
Wend
End If
Next qq
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich