AW: Spalten Werte in Reihen Werte überführen
27.08.2019 16:25:25
UweD
Hallo
also für das erste Beispile hier eine VBA Lösung (überwiegend zum Aufbau der Randbedingungen)
dabei werden aber auch Formeln benutzt und die Ergebnisse später in Werte umgewandelt.
Sub trans()
Dim TB1, TB2, LR As Integer, LC As Integer, Z As Integer, S As Integer
Dim i As Integer, j As Integer, k As Integer
Dim Jahre As String, Werte As String, Tmp As String, AnzJ As Integer, AnzW As Integer
Set TB1 = Sheets("Beispiel")
Set TB2 = Sheets("Ergebnis")
i = 2: j = 3: k = 2
LR = TB1.Cells(TB1.Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte
LC = TB1.Cells(1, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
With TB2
'reset
.Cells.Delete
'Überschriften setzen
.Cells(1, 1) = "Name"
.Cells(1, 2) = "Jahr"
For S = 2 To LC
'Leerzeichen am Ende entfernen
Tmp = Trim(TB1.Cells(1, S))
TB1.Cells(1, S) = Tmp
'unterschiedliche Jahre ermitteln
If InStr(Jahre, Right(Tmp, 4)) = 0 Then
Jahre = Jahre & "," & Right(Tmp, 4)
AnzJ = AnzJ + 1
End If
'Jahre eintragen
.Cells(i, 2) = Right(Tmp, 4)
i = i + 1
'unterschiedliche Werte ermitteln und eintragen
If InStr(Werte, Left(Tmp, Len(Tmp) - 5)) = 0 Then
Werte = Werte & "," & Left(Tmp, Len(Tmp) - 5)
.Cells(1, j) = Left(Tmp, Len(Tmp) - 5)
j = j + 1
AnzW = AnzW + 1
End If
Next S
'Namen wiederholt eintragen
For Z = 2 To LR
.Cells(k, 1).Resize(AnzJ) = TB1.Cells(Z, 1)
k = k + AnzJ
Next Z
'Formel bereich
With .Cells(2, 3).Resize(k - 2, AnzW)
'Formel eintragen: Index und 3-facher Vergleich
.FormulaR1C1 = "=INDEX(" & TB1.Name & "!R2C2:R" & LR & "C" & LC & ",MATCH(RC1," & TB1.Name & _
"!R2C1:R" & LR & "C1,0),MATCH(R1C&""*""," & TB1.Name & _
"!R1C2:R1C" & LC & ",0)+MATCH(""*""&RC2," & TB1.Name & "!R1C2:R1C" & LC & ",0)-1)"
'in Werte umwandeln
.Value = .Value
End With
End With
End Sub
C2:=INDEX(Beispiel!$B$2:$J$4;VERGLEICH($A2;Beispiel!$A$2:$A$4;0);VERGLEICH(C$1&"*";Beispiel!$B$1:$J$1;0)+VERGLEICH("*"&$B2;Beispiel!$B$1:$J$1;0)-1)
LG UweD