Daten übertragen von Sepp

Sub importData()
Dim objWB As Workbook, objOpen As Workbook
Dim lngRow As Long, lngCol As Long, lngI As Long, lngN As Long, lngLast As Long
Dim strFile As String
Dim bolOpen As Boolean
Dim lngCalc As Long
strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", 1, "Datei zum Datenimport auswählen")
If strFile = "Falsch" Then Exit Sub
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
With Me.Range("A8:H" & Me.Rows.Count)
.Clear
.Borders.LineStyle = xlNone
End With
lngN = 8
For Each objOpen In Application.Workbooks
If objOpen.FullName = strFile Then
Set objWB = objOpen
bolOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile)
With objWB.Sheets("Tabelle1") 'Name der Datentabelle - Anpassen!
lngLast = Application.Max(16, .Cells(.Rows.Count, 1).End(xlUp).Row)
For lngRow = 16 To lngLast
For lngCol = 16 To 70
If .Cells(lngRow, lngCol)  "" And .Cells(lngRow, lngCol)  8 Then
MsgBox lngN - 1 & " Datensätze importiert!", vbInformation, "Import"
With Me.Range("A8:F" & lngN - 1)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
Else
MsgBox "Keine Daten gefunden!", vbInformation, "Import"
End If
ErrExit:
With Err
If .Number  0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'importData'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - importData"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
Set objWB = Nothing
Set objOpen = Nothing
End Sub