Sub DateiAuswählen1()
Dim Dateiname As Variant
Dim lz As Long, lq As Long, i As Long
Dim wbQuelle As Workbook
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim arrQB, arrQD
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dateiname = Application.GetOpenFilename(FileFilter:="Excel-Dateien(*.xls*),*.xls*")
If Dateiname <> False Then
Set wbQuelle = Workbooks.Open(Filename:=Dateiname)
Set wsQuelle = wbQuelle.Worksheets(1)
lq = wsQuelle.Cells(wsQuelle.Rows.Count, 2).End(xlUp).Row
arrQB = wsQuelle.Cells(2, 2).Resize(lq - 1)
arrQD = wsQuelle.Cells(2, 4).Resize(lq - 1)
wbQuelle.Close SaveChanges:=False
Set wsZiel = ThisWorkbook.Worksheets("Haupt")
wird, damit er wieder ab diesen Zeilenwert einfügt
lz = wsZiel.Cells(wsZiel.Rows.Count, 5).End(xlUp).Row
Dim oDict, x As Long
Set oDict = CreateObject("Scripting.Dictionary")
For x = 4 To lz
oDict(wsZiel.Cells(x, 5).Value) = 0
Next
For i = LBound(arrQB) To UBound(arrQB)
If arrQB(i, 1) <> "" Then
If Not oDict.exists(arrQB(i, 1)) Then
lz = lz + 1
wsZiel.Cells(lz, "E").Value = arrQB(i, 1)
wsZiel.Cells(lz, "F").Value = arrQD(i, 1)
End If
End If
Next i
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub