Option Explicit
Private Sub umstrukturieren()
Dim rng As Range, tAV, AV, R&, I&, E&, E2&, Uns$()
Dim Out, lV, V, MInd&
Dim SpalteLohntext&, SpalteNamen&, SpalteStunden&
SpalteLohntext = 2
SpalteNamen = 3
SpalteStunden = 4
With ActiveSheet
Set rng = .Range(.Cells(2, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
End With
With rng
tAV = .Value
.Sort .Columns(SpalteLohntext)
AV = .Value
End With
getUniques AV, Uns, SpalteLohntext
E = UBound(Uns)
With rng
.Sort .Columns(SpalteNamen)
AV = .Value
End With
I = 1
ReDim Out(E + 1, I)
E2 = UBound(AV)
lV = AV(1, SpalteNamen)
For R = 2 To E2
V = AV(R, SpalteNamen)
MInd = getMatchInd(AV(R - 1, SpalteLohntext), Uns, E) + 1
Out(MInd, I) = AV(R - 1, SpalteStunden)
If R = E2 Or V <> lV Then
Out(0, I) = lV
lV = V
I = I + 1
ReDim Preserve Out(E + 1, I)
End If
Next
MInd = getMatchInd(AV(R - 1, SpalteLohntext), Uns, E) + 1
Out(MInd, I - 1) = AV(R - 1, SpalteStunden)
I = I - 1
ReDim Preserve Out(E + 1, I)
For R = 1 To E + 1
Out(R, 0) = Uns(R - 1)
Next
myTP Out, Out
With Sheets(2)
.Range(.Cells(1, 10), .Cells(1 + UBound(Out), 10 + UBound(Out, 2))).Value = Out
End With
rng.Value = tAV
End Sub
Private Function myTP(AV, AVtr)
Dim SaveAV, R&, C&, S1&, S2&, E1&, E2&
SaveAV = AV
S1 = LBound(AV)
S2 = LBound(AV, 2)
E1 = UBound(AV)
E2 = UBound(AV, 2)
ReDim AVtr(S2 To E2, S1 To E1)
For R = S1 To E1
For C = S2 To E2
AVtr(C, R) = SaveAV(R, C)
Next
Next
End Function
Private Function getMatchInd(ByVal str$, Uns$(), ByVal E&) As Long
Dim I&
For I = 0 To E
If str = Uns(I) Then
getMatchInd = I
Exit For
End If
Next
End Function
Private Sub getUniques(ByVal AV, ByRef Uns$(), ByVal C&)
Dim R&, I&, E&, V, lV
E = UBound(AV)
lV = AV(1, C)
ReDim Uns(0)
Uns(0) = lV
I = 1
For R = 2 To E
V = AV(R, C)
If Not IsError(V) And Not IsError(lV) Then
If V <> lV Or R = E Then
ReDim Preserve Uns(I)
Uns(I) = V
lV = V
I = I + 1
End If
End If
Next
End Sub