du hast mir vor längerer Zeit einen schönen VBA Code geschrieben, ich habe an der Quelltabelle etwas geändert und ein paar Zeilen angefügt, habe das auch in deinem Code angepasst, bekomme aber leider jetzt nur Zahlenwerte aus.
Wenn du mal kurz mal drüber schauen könntest währe SUPER!!
Vielen Dank im voraus
Andi
Die Datei
https://www.herber.de/bbs/user/98585.xlsm
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