Speicherort einmalig hinterlegen
02.08.2023 08:45:57
Chrisi
habe ein Makro wo man Dateien auswählen kann und die Daten von den Files eingelesen und verarbeitet werden (das ist aber nebensächlich). Worum es mir geht ist das der User in Tabellenblatt "Start" in Zelle "A15" seinen Speicherort (Pfad) eingeben kann und solang dieser nicht geändert wird immer automatisch dieser Speicherort geöffnet wird wenn man das Makro startet. (Multi-File-Select muss aber vorhanden bleiben).
Vielen Dank für eure Hilfe!
Hier mein Code:
Sub Unproduktivität()
'Variablen
Dim strFile As Variant
Dim geöffneteDatei 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
'Display und Alarme deaktivieren
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Start").Activate
Range("A15").Select
DateiPfad = ActiveCell.Value
'leere zellen in daten pro woche aktivieren
Worksheets("Pivot_aktuelle_Woche").Activate
ActiveSheet.ChartObjects("Diagramm 2").Activate
With ActiveChart
.PivotLayout.PivotTable.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = True
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Lohnart").PivotItems("(blank)").Visible = True
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = True
End With
'leere zellen in daten gesamt aktivieren
Worksheets("Pivot_gesamt").Activate
ActiveSheet.ChartObjects("Diagramm 1").Activate
With ActiveChart
.PivotLayout.PivotTable.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = True
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Lohnart").PivotItems("(blank)").Visible = True
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = True
End With
'Benutzter Bereich löschen
Worksheets("Daten_pro_Woche").Activate
Range("A1:F50").Select
Selection.Delete
Worksheets("Zwischenablage").Activate
Range("A1:R300").Select
Selection.Delete
'Datei auswahl(multi select)
varFiles = Application.GetOpenFilename(MultiSelect:=True)
'wenn kein File ausgewählt/"Abbrechen" gedrückt wurde
If VarType(varFiles) = vbBoolean Then
MsgBox ("Kein File asugewählt, bitte erneut versuchen")
Sheets("Start").Activate
Exit Sub
End If
For Each strFile In varFiles
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set geöffneteDatei = Workbooks.Open(Filename:=strFile)
'Datenimport & entfernen von header leerzeile
LRow1 = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:R" & LRow1).Select
Selection.Copy
ThisWorkbook.Activate
Sheets("Zwischenablage").Activate
Range("A1").Select
ActiveSheet.Paste
Range("A1:G1").Interior.ColorIndex = 6
Range("A1").Select
Ende = Range("A3").End(xlDown).Row
I = 0
Do Until I = Ende
If ActiveCell.Value = "" Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
I = I + 1
Loop
geöffneteDatei.Close
ThisWorkbook.Activate
'benötigte spalten kopieren
Worksheets("Zwischenablage").Activate
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Range("A1:A300,E1:E300,G1:G300,L1:L300,N1:N300,O1:O300").Select
Selection.Copy
Sheets("Alle_Daten").Activate
Range("A1").Select
If ActiveCell = "" Then
ActiveSheet.Paste
Else
'freie Zeile suchen für Kopie in Alle_Daten
erste_freie_Zeile = Cells(Rows.Count, 1).End(xlUp).Row
Cells(erste_freie_Zeile + 1, 1).Select
ActiveSheet.Paste
'überschriftenzeile gelb färben
Range("A1:G1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColor = 12632256
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'alle außer die erste Header zeile entfernen
For zeile = Range("A65536").End(xlUp).Row To 2 Step -1
If Cells(zeile, 1).Interior.ColorIndex = 6 Then
Rows(zeile).Delete
End If
Next zeile
End If
'kalenderwoche einfügen
Sheets("Alle_Daten").Select
Range("G1").Select
ActiveCell.Value = "Kalenderwoche"
Range("G1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
Selection.Font.Bold = True
End With
Columns("A:G").Select
Selection.EntireColumn.AutoFit
Range("G2").Select
LRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveCell.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"")"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G" & LRow)
'aktuellste Kalenderwoche filtern
JuengsteDatum = WorksheetFunction.Max(Worksheets("Alle_Daten").Columns(1))
Sheets("Start").Activate
Range("A12").Select
ActiveCell = JuengsteDatum
Range("B12").Select
ActiveCell.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 = ActiveCell.Value
Sheets("Alle_Daten").Activate
Sheets("Alle_Daten").Range("A1:G1").AutoFilter Field:=7, Criteria1:=KW
Sheets("Alle_Daten").UsedRange.Copy
Sheets("Daten_pro_Woche").Activate
Range("A1").Select
ActiveSheet.Paste
Sheets("Alle_Daten").Activate
ActiveSheet.AutoFilterMode = False
'duplikate entfernen in alle daten
Sheets("Alle_Daten").Select
Application.CutCopyMode = False
Columns("A:G").Select
ActiveSheet.Range("$A$1:$G$250000").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
'duplikate entfernen in daten pro woche
Sheets("Daten_pro_Woche").Select
Application.CutCopyMode = False
Columns("A:G").Select
ActiveSheet.Range("$A$1:$G$250000").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
'refresh pivot
Sheets("Pivot_aktuelle_Woche").Select
ActiveSheet.ChartObjects("Diagramm 2").Activate
ActiveChart.PivotLayout.PivotTable.PivotCache.Refresh
Sheets("Pivot_gesamt").Select
ActiveSheet.ChartObjects("Diagramm 1").Activate
ActiveChart.PivotLayout.PivotTable.PivotCache.Refresh
Next
'leerzeilen im daten pro woche deaktivieren
Worksheets("Pivot_aktuelle_Woche").Activate
ActiveSheet.ChartObjects("Diagramm 2").Activate
With ActiveChart
.PivotLayout.PivotTable.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = False
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Lohnart").PivotItems("(blank)").Visible = False
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = False
End With
'leerzeilen im daten gesamt deaktivieren
Worksheets("Pivot_gesamt").Activate
ActiveSheet.ChartObjects("Diagramm 1").Activate
With ActiveChart
.PivotLayout.PivotTable.PivotFields("TATätigkeit-TXT").PivotItems("(blank)").Visible = False
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Lohnart").PivotItems("(blank)").Visible = False
End With
With ActiveChart
.PivotLayout.PivotTable.PivotFields("Kalenderwoche").PivotItems("(blank)").Visible = False
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
MfG Chrisi