der Vollständigkeit halber
02.08.2023 11:46:00
Rudi Maintaire
Hallo,
so könnte das aussehen:
Sub Unproduktivitaet()
'Variablen
Dim strFile As Variant
Dim GeoeffneteDatei As Workbook
Dim erste_freie_Zeile As Long
Dim zeile As Long
Dim Ende As Long
Dim LRow As Integer
Dim LRow1 As Integer
Dim wksWeek As Worksheet
Dim wksAll As Worksheet
Dim dtCurrent As Date, dtMonday As Date, dtRow As Date
Dim lngRowLastEntry As Long, lngRowMonday As Long
Dim lngFirstCol As Long, lngLastCol As Long
Dim I As Long
Dim varFiles As Variant
Dim JuengsteDatum As Date
Dim KW As String
Dim DateiPfad As String
Dim wksZA As Worksheet, wksWD As Worksheet, wksAlle As Worksheet, wksStart As Worksheet
'Display und Alarme deaktivieren
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DateiPfad = Sheets("Start").Range("A15")
If Right(DateiPfad, 1) > "\" Then DateiPfad = DateiPfad & "\"
Set wksZA = ThisWorkbook.Worksheets("Zwischenablage")
Set wksWD = ThisWorkbook.Worksheets("Daten_pro_Woche")
Set wksAlle = ThisWorkbook.Worksheets("Alle_Daten")
Set wksStart = ThisWorkbook.Worksheets("Start")
'leere zellen in daten pro woche aktivieren
With Worksheets("Pivot_aktuelle_Woche")
With .ChartObjects("Diagramm 2")
With .PivotLayout.PivotTable
.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = True
.PivotFields("Lohnart").PivotItems("(blank)").Visible = True
.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = True
End With
End With
End With
'leere zellen in daten gesamt aktivieren
With Worksheets("Pivot_gesamt")
With .ChartObjects("Diagramm 1")
With .PivotLayout.PivotTable
.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = True
.PivotFields("Lohnart").PivotItems("(blank)").Visible = True
.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = True
End With
End With
End With
'Benutzten Bereich löschen
wksWD.Range("A1:F50").Delete
wksZA.Range("A1:R300").Delete
'Datei auswahl(multi select)
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = DateiPfad
.Filters.Add "Excel-Dateien", "*.xls*"
.FilterIndex = .Filters.Count
If .Show Then
Set varFiles = .SelectedItems
Else
'wenn kein File ausgewählt/"Abbrechen" gedrückt wurde
MsgBox "Keine Datei ausgewählt.", , "Abbruch"
Exit Sub
End If
End With
For Each strFile In varFiles
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set GeoeffneteDatei = Workbooks.Open(Filename:=strFile)
'Datenimport & entfernen von header leerzeile
LRow1 = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:R" & LRow1).Copy wksZA.Range("A1")
GeoeffneteDatei.Close False
With wksZA
.Range("A1:G1").Interior.ColorIndex = 6
Ende = .Range("A3").End(xlDown).Row
For I = Ende To 1 Step -1
If .Cells(I, 1) = "" Then
.Rows(I).Delete
End If
Next I
End With
With wksAlle
If .Cells(1, 1) = "" Then
erste_freie_Zeile = 1
Else
erste_freie_Zeile = .Cells(Rows.Count, 1).End(xlUp).Row
End If
End With
With wksZA
'benötigte spalten kopieren
.Columns("A:A").NumberFormat = "m/d/yyyy"
.Range("A1:A300,E1:E300,G1:G300,L1:L300,N1:N300,O1:O300").Copy wksAlle.Cells(erste_freie_Zeile, 1)
End With
With wksAlle
'überschriftenzeile gelb färben
With .Range("A1:G1")
.Pattern = xlSolid
.PatternColor = 12632256
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'alle außer die erste Header zeile entfernen
For zeile = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(zeile, 1).Interior.ColorIndex = 6 Then
.Rows(zeile).Delete
End If
Next zeile
End With
'kalenderwoche einfügen
With wksAlle
With .Range("G1")
.Value = "Kalenderwoche"
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
.Font.Bold = True
End With
End With
.Columns("A:G").AutoFit
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("G2:G" & LRow).FormulaR1C1 = _
"=TEXT(TRUNC((RC[-6]-DATE(YEAR(RC[-6]+3-MOD(RC[-6]-2,7)),1,MOD(RC[-6]-2,7)-9))/7),""00"")&""/""&TEXT(RC[-6],""JJ"")"
'aktuellste Kalenderwoche filtern
JuengsteDatum = WorksheetFunction.Max(.Columns(1))
End With
With wksStart
.Range("A12") = JuengsteDatum
.Range("B12").FormulaR1C1 = _
"=TEXT(TRUNC((RC[-1]-DATE(YEAR(RC[-1]+3-MOD(RC[-1]-2,7)),1,MOD(RC[-1]-2,7)-9))/7),""00"")&""/""&TEXT(RC[-1],""JJ"")"
KW = .Range("B12").Value
End With
With wksAlle
.Range("A1:G1").AutoFilter Field:=7, Criteria1:=KW
.UsedRange.Copy wksWD.Range("A1")
.AutoFilterMode = False
End With
'duplikate entfernen in alle daten
wksAlle.Columns("A:G").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
'duplikate entfernen in daten pro woche
wksWD.Columns("A:G").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
'refresh pivot
Sheets("Pivot_aktuelle_Woche").ChartObjects("Diagramm 2").PivotLayout.PivotTable.PivotCache.Refresh
Sheets("Pivot_gesamt").ChartObjects("Diagramm 1").PivotLayout.PivotTable.PivotCache.Refresh
Next strFile
'leerzeilen im daten pro woche deaktivieren
With Worksheets("Pivot_aktuelle_Woche")
With .ChartObjects("Diagramm 2")
With .PivotLayout.PivotTable
.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = False
.PivotFields("Lohnart").PivotItems("(blank)").Visible = False
.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = False
End With
End With
End With
'leerzeilen im daten gesamt deaktivieren
With Worksheets("Pivot_gesamt")
With .ChartObjects("Diagramm 1")
With .PivotLayout.PivotTable
.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = False
.PivotFields("Lohnart").PivotItems("(blank)").Visible = False
.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = False
End With
End With
End With
Worksheets("Start").Activate
Range("A12:B12").Delete
MsgBox ("Kopieren aller Daten erfolgreich beendet")
'Display und Alarme aktivieren
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
ungetestet! (wie auch)
Gruß
Rudi