Hallo Sepp
sorry, daran soll es nicht scheitern:
Public Sub Daten_importieren()
Dim strPath As String, strPattern As String, strFile As String, strTemp As String
Dim FF As Integer, lngRow As Long
'Dateidialog für Auswahl
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\Standardordner\"
.Title = "Ablagepfad für pdf-Datei auswählen"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) "\" Then strPath = strPath & "\"
End If
End With
With ActiveSheet
If Len(strPath) Then
strPattern = "*.txt"
strFile = Dir(strPath & strPattern, vbNormal)
Do While strFile ""
lngRow = .UsedRange.Rows.Count
FF = FreeFile
Open strPath & strFile For Input As #FF
Do While Not EOF(FF)
Line Input #FF, strTemp
.Cells(lngRow, 1) = Replace(strTemp, vbTab, ";")
lngRow = lngRow + 1
Loop
Close #FF
'------eingelesene Textdatei welche in einer Zelle stehen in mehrer spalten aufteilen Trenner _
ist Leerzeichen---
Dim lngLetzte As Long
With ThisWorkbook.Sheets("x1")
lngLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, . _
Rows.Count)
.Range(.Cells(1, 1), .Cells(lngLetzte, 1)).TextToColumns Destination:=.Cells(1, 1), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False
End With
Worksheets("x1").Activate
Dim zFK As Integer, zFFR As Integer, l As Integer, m As Integer, n As Integer, o As Integer, p _
As Integer, q As Integer
Dim r As Integer, s As Integer, t As Integer, u As Integer, v As Integer, w As Integer, x As _
Integer, y As Integer
Dim z As Integer, z1 As Integer, z2 As Integer, z3 As Integer, z4 As Integer, k As Integer
Application.ScreenUpdating = False
'Zeilen mit "PART" löschen
On Error GoTo Naechste:
Dim l5 As Double
For l5 = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(l5, 1).Value = "PART" Then
Rows(l5).Delete
End If
Next l5
Naechste:
zFK = Range("A:A").Find(What:="FCFKONZEN1", SearchDirection:=xlUp).Row
zFR = Range("A:A").Find(What:="FCFRUNDHT1", SearchDirection:=xlUp).Row
Cells(zFK, 1).Copy
Cells(zFK, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
Cells(zFR, 1).Copy
Cells(zFR, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
l = Range("B:B").Find(What:="Gauß=", SearchDirection:=xlUp).Row
m = Range("B:B").Find(What:="FCFRUNDHT1", SearchDirection:=xlUp).Row
n = Range("B:B").Find(What:="Z_3UHR=", SearchDirection:=xlUp).Row
o = Range("B:B").Find(What:="Z_12UHR=", SearchDirection:=xlUp).Row
p = Range("B:B").Find(What:="Z_9UHR", SearchDirection:=xlUp).Row
q = Range("B:B").Find(What:="Z_6UHR", SearchDirection:=xlUp).Row
r = Range("B:B").Find(What:="BOHRUNG_1=", SearchDirection:=xlUp).Row
s = Range("B:B").Find(What:="BOHRUNG_2=", SearchDirection:=xlUp).Row
t = Range("B:B").Find(What:="BOHRUNG_3=", SearchDirection:=xlUp).Row
u = Range("B:B").Find(What:="BOHRUNG_4=", SearchDirection:=xlUp).Row
v = Range("B:B").Find(What:="BOHRUNG_5", SearchDirection:=xlUp).Row
w = Range("B:B").Find(What:="BOHRUNG_6=", SearchDirection:=xlUp).Row
x = Range("B:B").Find(What:="BOHRUNG_7=", SearchDirection:=xlUp).Row
y = Range("B:B").Find(What:="TIEFE_BOHRUNG_1=", SearchDirection:=xlUp).Row
z = Range("B:B").Find(What:="AUSENDURCHMESSER=", SearchDirection:=xlUp).Row
z1 = Range("B:B").Find(What:="BREITE_Y=", SearchDirection:=xlUp).Row
z2 = Range("B:B").Find(What:="BREITE_X=", SearchDirection:=xlUp).Row
z3 = Range("B:B").Find(What:="BREITE_Y=", SearchDirection:=xlUp).Row
z4 = Range("B:B").Find(What:="FCFKONZEN1", SearchDirection:=xlUp).Row
k = Range("A:A").Find(What:="SNR", SearchDirection:=xlUp).Row
Range(Cells(l + 1, 2), Cells(l + 2, 7)).Copy
Range(Cells(l, 3), Cells(l, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(l + 2, 2), Cells(l + 2, 7)).Copy
Range(Cells(l, 3), Cells(l, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(m + 2, 2), Cells(m + 2, 7)).Copy
Range(Cells(m, 3), Cells(m, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(n + 2, 2), Cells(n + 2, 7)).Copy
Range(Cells(n, 3), Cells(n, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(o + 2, 2), Cells(o + 2, 7)).Copy
Range(Cells(o, 3), Cells(o, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(p + 2, 2), Cells(p + 2, 7)).Copy
Range(Cells(p, 3), Cells(p, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(q + 2, 2), Cells(q + 2, 7)).Copy
Range(Cells(q, 3), Cells(q, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(r + 2, 2), Cells(r + 2, 7)).Copy
Range(Cells(r, 3), Cells(r, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(s + 2, 2), Cells(s + 2, 7)).Copy
Range(Cells(s, 3), Cells(s, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(t + 2, 2), Cells(t + 2, 7)).Copy
Range(Cells(t, 3), Cells(t, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(u + 2, 2), Cells(u + 2, 7)).Copy
Range(Cells(u, 3), Cells(u, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(v + 2, 2), Cells(v + 2, 7)).Copy
Range(Cells(v, 3), Cells(v, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(w + 2, 2), Cells(w + 2, 7)).Copy
Range(Cells(w, 3), Cells(w, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(x + 2, 2), Cells(x + 2, 7)).Copy
Range(Cells(x, 3), Cells(x, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(y + 2, 2), Cells(y + 2, 7)).Copy
Range(Cells(y, 3), Cells(y, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(z + 2, 2), Cells(z + 2, 7)).Copy
Range(Cells(z, 3), Cells(z, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(z1 + 2, 2), Cells(z1 + 2, 7)).Copy
Range(Cells(z1, 3), Cells(z1, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(z2 + 2, 2), Cells(z2 + 2, 7)).Copy
Range(Cells(z2, 3), Cells(z2, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(z3 + 2, 2), Cells(z3 + 2, 7)).Copy
Range(Cells(z3, 3), Cells(z3, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
Range(Cells(z4 + 2, 2), Cells(z4 + 2, 7)).Copy
Range(Cells(z4, 3), Cells(z4, 8)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False
'''' Zeile mit ACH, M, z d in Spalte 5 finden und ganze Zeile löschen
Dim loeschen As Double
For loeschen = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(loeschen, 1).Value = "ACH" Then
Rows(loeschen).Delete
End If
Next loeschen
Dim l2 As Double
For l2 = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(l2, 1).Value = "M" Then
Rows(l2).Delete
End If
Next l2
Dim l3 As Double
For l3 = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(l3, 1).Value = "Z" Then
Rows(l3).Delete
End If
Next l3
Dim l4 As Double
For l4 = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(l4, 1).Value = "D" Then
Rows(l4).Delete
End If
Next l4
'Spalten I:M löschen
Range("I:M").ClearContents
'SNR,Datum,Time,Werkstück verschieben
Dim SNR As Integer
SNR = Range("A:A").Find(What:="SNR", SearchDirection:=xlPrevious).Row
Cells(SNR, 3).Copy
Cells(l, 9).PasteSpecial Paste:=xlPasteAll
Dim Dte As Integer
Dte = Range("A:A").Find(What:="Date=*", SearchDirection:=xlPrevious).Row
Cells(Dte, 1).Copy
Cells(l + 1, 9).PasteSpecial Paste:=xlPasteAll
Dim tme As Integer
tme = Range("B:B").Find(What:="TIME=*", SearchDirection:=xlPrevious).Row
Cells(tme, 2).Copy
Cells(l + 2, 9).PasteSpecial Paste:=xlPasteAll
Dim wrk As Integer
wrk = Range("A:A").Find(What:="WERK*", SearchDirection:=xlPrevious).Row
Cells(wrk, 3).Copy
Cells(l + 3, 9).PasteSpecial Paste:=xlPasteAll
'Datenbereich nach "DB" kopieren
Dim DB As Worksheet
Dim letzte_zeile As Integer
Range(Cells(l, 2), Cells(zFK, 9)).Copy
Worksheets("DB").Activate
letzte_zeile = Worksheets("DB").Cells(Rows.Count, 2).End(xlUp).Row
Cells(letzte_zeile + 1, 2).PasteSpecial Paste:=xlPasteAll
'''Alle Zahlen im Blatt DB durch 1000 teilen um Komma richtigh zu setzen''''''
Dim zl As Integer
Dim zg As Integer
Dim teile As Range
Dim fak As Variant
Dim zelle As Range
fak = 1000
Worksheets("DB").Activate
zl = Worksheets("DB").Cells(Rows.Count, 2).End(xlUp).Row
zg = Range("B:B").Find(What:="D_GAUß=", SearchDirection:=xlPrevious).Row
Set teile = Range(Cells(zg, 2), Cells(zl, 8))
For Each zelle In teile
If IsNumeric(zelle.Value) Then
zelle.Formula = zelle.Value / fak
End If
Next zelle
'alle Striche auf dünn
Worksheets("DB").Range(Cells(zg, 2), Cells(zl, 9)).Borders(xlInsideHorizontal).Weight = xlThin
Worksheets("DB").Range(Cells(zg, 2), Cells(zl, 9)).Borders(xlInsideVertical).Weight = xlThin
'dicken Querstrich nach Substratende
Worksheets("DB").Range(Cells(zg, 2), Cells(zl, 9)).Borders(xlEdgeBottom).Weight = xlMedium
'Tabellenblattx1 löschen
'Tabellenblatt nach Beendigung des makros löschen
Application.DisplayAlerts = False
Worksheets("X1").Delete
Worksheets.Add.Name = "X1"
Application.DisplayAlerts = True
'Bildschirmausgabe wieder an
Application.ScreenUpdating = True
' Das nächste txt. File im Verzeichnis c:\vba abarbeiten
strFile = Dir
Loop
End If
End With
End Sub
Nach dem ersten Durchlauf zeigt der debugger Laufzeitfheler 91 in zeile:
zFK = Range("A:A").Find(What:="FCFKONZEN1", SearchDirection:=xlUp).Row
Damit hat er auch vollkommen recht den im Tabellenblat x1 befinden sich keine eingelesenen Daten und somit kann es das wort "FCKONZEN1" auch nicht finden.
Grüße