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

MfG Dima

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 Kalenderwoche As Integer
    Dim Kalenderjahr 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
    
    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
    Kalenderwoche = FormulaR1C1 = "=WEEKNUM(RC[-6],21)"
    MsgBox (Kalenderwoche)
    'ActiveCell.FormulaR1C1 = "=WEEKNUM(RC[-6],21)"
    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