Option Explicit
Sub Daten_importieren()
Dim filSRC As Excel.Workbook
Dim strSRC As String
Dim shtTRG As Excel.Worksheet
Dim rngSearch As Excel.Range
Dim rngZelle As Excel.Range
Dim lngFreieZeile As Long
Dim bolExist As Boolean
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Set shtTRG = ThisWorkbook.Sheets("Sheet1")
With shtTRG
lngFreieZeile = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row + 1
strSRC = Application.GetOpenFilename("Excel-Arbeitsmappe (*.xls),*.xls,Excel2007-Arbeitsmappe (*.xlsx),*.xlsx", 1, "Importdatei auswählen...", "Importdatei", False)
If strSRC = "" Or strSRC = "Falsch" Then
Set shtTRG = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
Set filSRC = Application.Workbooks.Open(strSRC, , True): DoEvents
Set rngSearch = .Range("B1:" & CStr(lngFreieZeile - 1))
bolExist = False
For Each rngZelle In rngSearch
If rngZelle = filSRC.Sheets(1).Range("B1") Then
rngZelle.EntireRow.Columns("A") = filSRC.Sheets(1).Range("A1")
rngZelle.EntireRow.Columns("B") = filSRC.Sheets(1).Range("B1")
rngZelle.EntireRow.Columns("C") = filSRC.Sheets(1).Range("C1")
rngZelle.EntireRow.Columns("D") = filSRC.Sheets(1).Range("D1")
bolExist = True
Exit Do
End If
Next
If bolExist = False Then
.Cells(lngFreieZeile, "A") = filSRC.Sheets(1).Range("A1")
.Cells(lngFreieZeile, "B") = filSRC.Sheets(1).Range("B1")
.Cells(lngFreieZeile, "C") = filSRC.Sheets(1).Range("C1")
.Cells(lngFreieZeile, "D") = filSRC.Sheets(1).Range("D1")
End If
filSRC.Close False
Set filSRC = Nothing
Set rngSearch = Nothing
End With
Set shtTRG = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub