Entpivotierung ohne Power Query
16.02.2023 21:06:55
Yal
Hallo Anika,
Diese Beitrag hat eine geringe Relevanz, da Du eine funktionierende Formel von Werner bekommen hast, die deine Bedarf abdeckt.
Da ich aber den Spass hatte, diese Nuss zu knacken, und weil vielleicht doch irgendwann jemand änhliches per VBA möchte, eine VBA-Lösung.
(Entpivotieren per VBA habe ich, seit ich Power Query kenne, nicht mehr gemacht. Aber die Quelle war ...schwierig)
Dim Arr()
Sub Entpivotieren()
Daten_Lesen
'Information Tabellerisch ausgeben (geht einfach)
Worksheets.Add.Range("A1").Resize(UBound(Arr, 2) + 1, 4) = Application.Transpose(Arr)
'Daten nach Vorgabe ablegen (geht schwieriger)
DatenNachVorgabe_ablegen
End Sub
Sub Daten_Lesen()
Dim R As Long 'Row
Dim C As Long 'Column
Dim j As Long
Const cEZ = 7 'erste Datenzeile
Const cES = 13 'erste Datenspalte "M" (= Spalte 13)
ReDim Arr(3, 0)
Arr(0, 0) = "Mitarbeiter"
Arr(1, 0) = "Datum"
Arr(2, 0) = "Schicht"
Arr(3, 0) = "Anwesenheit"
'Information sammeln (passiert in der ActiveSheet oder im Blatt, wo diese code abgelegt ist
For R = cEZ To Cells(Rows.Count, "B").End(xlUp).Row
For C = cES To Cells(R, Columns.Count).End(xlToLeft).Column Step 3
If Cells(R, C) > "" Then
j = j + 1
ReDim Preserve Arr(3, j)
Arr(0, j) = Cells(R, "B").Value 'Mitarbeiter
Arr(1, j) = CDate(Cells(5, C).Value) 'Datum
Arr(2, j) = UCase(Trim(Cells(R, C).Value)) 'Schicht
Arr(3, j) = UCase(Trim(Cells(R, C + 2).Value)) 'Anwesenheit. Es gibt einen eintrag mit einem leerzeichen davor :-)
End If
Next
Next
End Sub
Sub DatenNachVorgabe_ablegen()
Dim R As Long 'Row
Dim C As Long 'Column
Dim j As Long
Dim Versatz As Long
Const cEZ = 5 'erste Abgabezeile
Const cES = 3 'erste Abgabespalte "C" (=3)
Application.ScreenUpdating = False
Application.EnableEvents = False
'Information "as expected" ausgeben
With Worksheets.Add
For j = 1 To UBound(Arr, 2)
R = WorksheetFunction.WeekNum(Arr(1, j)) * 9 + cEZ - 9 'Wochenzeile
C = WorksheetFunction.Weekday(Arr(1, j), 2) * 5 + cES - 5 'Tagesspalte
.Cells(R, C) = Arr(1, j) 'Datum
.Cells(R + 1, C).Resize(1, 4) = Array("F", "T", "S", "N") 'wichtig wg End(xlup)
If Arr(3, j) = "A" Then 'nur bei nicht krank, nicht Urlaub
Select Case Arr(2, j)
Case "F": Versatz = 0
Case "T": Versatz = 1
Case "S": Versatz = 2
Case "N": Versatz = 3
End Select
.Cells(R, C).Offset(8, Versatz).End(xlUp).Offset(1, 0) = Arr(0, j)
End If
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Daten sammeln geht eigentlich relativ leicht.
Tabellerisch abgeben ist nur eine Zeile.
Nach vogegebene Format ist, wie vermutet, anstregender. Ich habe auf Formatierung verzichtet (Zellefarbe und Text zentriert über Spalten). Es lässt sich leicht hinzufügen.
VG
Yal