Hallo Zusammen,

habe eig nur ein simples Problem, stehe aber trotzdem an mit meinem Grundlegenden VBA-Kenntnissen.

habe ein Programm geschrieben welches (bis jetzt) ein File einliest und dieses dann weiter verarbeitet, nun soll aber nicht nur ein File aufeinmal eingelesen werden können, sondern so viele wie man will (aufeinmal).

Ich weiß aber nicht wie man einen Multiselect macht und da ich meinen Code schon auf den Singleselect getrimmt habe, finde ich keine passenden Beispiele im Internet dafür.

Hoffe mir kann jemand helfen, folgend der VBA-Code:

Sub Unproduktivität()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


'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 Kalenderjahr As String
Kalenderjahr = "/23"
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

Worksheets("Daten_pro_Woche").Activate
Range("A1:F30").Select
Selection.Delete

Worksheets("Zwischenablage").Activate
Range("A1:R300").Select
Selection.Delete

'Datei auswahl
strFile = Application.GetOpenFilename
Set geöffneteDatei = Workbooks.Open(Filename:=strFile)




'Überschreiben von Datenbank File auf Excel Datei
Set geöffneteDatei = ActiveWorkbook



'Datenimport & entfernen von header leerzeile
Range("A1:R300").Copy
ThisWorkbook.Activate
Sheets("Zwischenablage").Activate
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Ende = Range("A3").End(xlDown).Row
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


' spaltenKopieren
Worksheets("Zwischenablage").Activate
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy"
Range("A1:A150,E1:E150,G1:G150,L1:L150,N1:N150,O1:O150").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
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 = "=WEEKNUM(RC[-6],21)"
'=TEXT(KÜRZEN((A2-DATUM(JAHR(A2+3-REST(A2-2;7));1;REST(A2-2;7)-9))/7);"00")&"/"&TEXT(A2;"JJ")
Range("G2").AutoFill Destination:=Range("G2:G" & LRow), Type:=xlFillDefault




Set wksAll = ThisWorkbook.Worksheets("Alle_Daten")
Set wksWeek = ThisWorkbook.Worksheets("Daten_pro_Woche")
lngFirstCol = 1
lngLastCol = 7


lngRowLastEntry = wksAll.Cells(Rows.Count, lngFirstCol).End(xlUp).Row
'Letztes Datum in der ersten Spalte
dtCurrent = CDate(Int(wksAll.Cells(lngRowLastEntry, lngFirstCol).Value))
'Montag dieser Woche
dtMonday = DateAdd("d", -((Weekday(dtCurrent) + 5) Mod 7), dtCurrent)

' Zeile suchen, die vor dem Montag der Woche liegt
i = lngRowLastEntry
Do
i = i - 1
dtRow = wksAll.Cells(i, lngFirstCol).Value
Loop Until dtRow dtMonday And i > 2

' erste zu kopierende Zeile
lngRowMonday = i + 1

' Wochendaten löschen
wksWeek.usedRange.ClearContents
' Wochendaten neu kopieren
wksAll.Range(Cells(lngRowMonday, lngFirstCol).Address, Cells(lngRowLastEntry, lngLastCol).Address).Copy wksWeek.Range("A2")



'Headerzeile hinzufügen
Sheets("Alle_Daten").Activate
Range("A1:G1").Select
Selection.Copy
Sheets("Daten_pro_Woche").Activate
Range("A1").Select
ActiveSheet.Paste
Columns("A:G").Select
Selection.EntireColumn.AutoFit

'duplikate entfernen
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

'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


Worksheets("Start").Activate
MsgBox ("Kopieren aller Daten erfolgreich beendet")

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub