AW: versuchs nochmal
24.02.2021 13:58:21
Yal
Hallo Gaby,
schwierig.
Ich gehe davon aus, dass die Tabellen "KW 2", "KW 3" usw heissen (mit oder ohne Leerzeichen, hauptsache Wochennummer am Ende), uns dass es keine anderen Tabellen als "KW x" in der Datei gibt.
Was wird gemacht: über alle Tabelle gehen und alle Daten in einer "Übersicht" sammeln. Darauf kannst Du eine Pivottabelle bauen (ganz easy. Tutorials in youtube)
Gehe auf dem Reiter eines Blattes, mit rechten Maustaste "Code anzeigen". Es öffnet sich den VB-Editor.
Es sollte links das "Projekt"-Fenster sichtbar sein. Wenn nicht Strg+r.
Im Menü Einfügen, Modul anfügen. Siehe im Projekt, es hat sich ein Modul1 eingefügt.
Doppelklick auf diesem Modul1 und darin den Code einfügen.
Und dann laufen lassen.
Sub Übersicht_herstellen()
Dim wZ As Worksheet 'Ziel
Dim wQ As Worksheet 'Quelle
Dim z As Long 'ZeileNr
Dim s As Long 'SpalteNr
Dim kwFaktor As Integer
Const KW1Montag = "06.01.2020"
Set wZ = Übersicht_vorbereiten
For Each wQ In ThisWorkbook.Worksheets
If wQ.Name wZ.Name Then
kwFaktor = NameZuWoche(wQ.Name) - 1
For z = 2 To wQ.Range("A9999").End(xlUp).Row
With wZ.Range("A9999").End(xlUp).Offset(1, 0)
.Value = wQ.Cells(z, 1) 'Name Mitarbeiter in Spalte 1
For s = 2 To 6
.Offset(0, 1) = CDate(KW1Montag) + kwFaktor * 7 + s - 2 'Datum in _
Spalte 2
.Offset(0, 2) = wQ.Name 'Woche, bzw Quell-Blattname in Spalte 3
.Offset(0, 3) = IIf(wQ.Cells(z, s) = "", "normal", wQ.Cells(z, s)) ' _
Eintrag für MA in Spalte 4
.Offset(0, 4) = 1 'Tageswert, immer 1, für die Summierung
Next
End With
Next
End If
Next
End Sub
Private Function Übersicht_vorbereiten() As Worksheet
'nicht vorhanden: herstellt die Übersicht
'bereit vorhanden: leert die Übersicht
Dim w As Worksheet
On Error Resume Next
Set w = ThisWorkbook.Worksheets("Übersicht")
If w Is Nothing Then
ThisWorkbook.Sheets.Add After:=ActiveSheet
Set w = ActiveSheet
z.Name = "Übersicht"
z.Range("A1:E1") = Array("Name", "Datum", "Woche", "Status", Wert)
Else
w.Range("A2", w.UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents
End If
Set Übersicht_vorbereiten = w
End Function
Private Function NameZuWoche(WName As String) As Integer
'Extrahiert die Zahlen am Ende eines Textes
' KW 9 --> 9, kw11 --> 11
Dim s, i
Do While IsNumeric(Mid(WName, Len(WName) - i, 1))
s = s & Mid(WName, Len(WName) - i, 1)
i = i + 1
Loop
NameZuWoche = CInt(s)
End Function
Viel Erfolg
Yal