VBA Datei automatisch aus Ordner öffnen und einlesen

Option Explicit





    Sub Import_DATEI_Data()



    Dim wiMaster As Office.FileDialog

    Dim SvName As String

    Dim strInput As String

    Dim strFile As String

    Dim wbRGdata As Workbook, wbMaster As Workbook

    Dim wsRateshop As Worksheet, WsMaster As Worksheet

    Dim firstline As Double

    Dim tbl()

    Dim varRegion, pvTab As PivotTable, pvField As PivotField

    Dim varMG01



    Set wbMaster = ThisWorkbook

    Set wiMaster = Application.FileDialog(msoFileDialogFilePicker)

    Set WsMaster = wbMaster.Sheets("Import Datei")

    varMG01 = ThisWorkbook.Sheets("Beispiel").Range("N4").Value



    With wiMaster



    .Filters.Clear

    .Filters.Add "Excel Files", "*.xlsx?", 1

    .Title = "Choose an Excel file"

    .AllowMultiSelect = False





    .InitialFileName = "C:\Users\" & Environ("Username") & "\Documents\...\" & Format(Now, "yyyy") & "\...\" & Format(Now, "mm") & " " & Format(Now, "mmmm") & " " & Format(Now, "yyyy") & "\" & Format(Now, "dd.mm") & " " & "Lokal" & "\" & varMG01 & "\" & "..." & "\" & "DATEINAME_" & Format(Now, "yyyymmdd") & "*.xlsx"""

 

    If .Show = True Then



        strFile = .SelectedItems(1)



    Else

    

        Exit Sub

    

    End If



    End With



    Set wbRGdata = Workbooks.Open(strFile)

    Set wsRateshop = ActiveSheet

        

        'copy data

    With wsRateshop

    tbl = .Range("A1:BZ30000").Value2

    End With



       'copy on top

       With WsMaster

            firstline = .Cells(.Rows.Count, 1).End(xlUp).Row + 0

     .Cells(firstline, 1).Resize(UBound(tbl), UBound(tbl, 2)) = tbl

               

     End With

            

    'Namen der Datei einfügen

    Dim strFileName01 As String

    strFileName01 = Format(Now, "dd.mm.yyyy hh:mm")

    wbMaster.Sheets("Beispiel").Range("A6").Value = strFileName01

    

    'Namen der Datei einfügen

    Dim strFileName02 As String

    strFileName02 = Mid(strFile, InStrRev(strFile, "\", , vbTextCompare) + 1)

    wbMaster.Sheets("Beispiel").Range("E4").Value = strFileName02

    

    'close import file

    wbRGdata.Close (False)

   

   

    Dim raFund As Range, loLetzte As Long, i As Long

    Dim wsZ As Worksheet, wsQ As Worksheet, strSuchbegriff As String

    Set wsZ = ThisWorkbook.Worksheets("data Datei")

    Set wsQ = ThisWorkbook.Worksheets("Import Datei")

    Application.ScreenUpdating = False

    With wsZ

    'vorhandene Daten im Blatt 2 löschen

    loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row

    If loLetzte > 1 Then

    .Range(.Cells(2, 1), .Cells(loLetzte, 16)).ClearContents

    End If

    'Schleife über die Überschriften im Blatt 2

    For i = 1 To 16

    strSuchbegriff = .Cells(1, i)

    'entspr. Überschrift im Blatt 3 suchen

    With wsQ

    Set raFund = .Rows("1:1").Find(what:=strSuchbegriff, LookIn:=xlValues, lookat:= _

    xlWhole)

    'wenn gefunden Daten kopieren

    If Not raFund Is Nothing Then

    loLetzte = .Cells(.Rows.Count, raFund.Column).End(xlUp).Row

    .Range(.Cells(2, raFund.Column), .Cells(loLetzte, raFund.Column)).Copy

    End If

    End With

    'im Blatt 2 in die entspr. Spalte einfügen

    .Cells(2, i).PasteSpecial Paste:=xlPasteValues

    Application.CutCopyMode = False

    Next i

    End With

    Set wsZ = Nothing: Set wsQ = Nothing

   

   

    Application.ScreenUpdating = True



    Application.ThisWorkbook.RefreshAll



 

    'Worksheets("Import Datei").Delete

    Worksheets("Import Datei").Range("A2:NTP100000").ClearContents

  

    MsgBox ("Import data and saving successful")

    

    End Sub