Dialog Pfad öffnen

Hallo liebes Forum,
ich habe folgenden Code welcher mir eine Dialogbox zum Auswählen eines Pfades öffnen soll. Dieser Pfad (GivePath) soll dann weiter zum öffnen von txt.-Dateien verwendet werden. Die Aufforderung zur Auswahl des Pfades kommt zwar, nach dem Auswählen und ok klicken passiert aber leider nichts mehr, sprich der Pfad wird nicht weiter übergeben. Was mache ich falsch?
"Private Sub Test()
ActiveSheet.Name = "x1"
Worksheets("x1").Activate
Dim path As String
Dim pattern As String
Dim file As String
Dim GivePath As String
Dim fDialog As FileDialog
Dim result As Integer
'Dateidialog für Auswahl
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
On Error Resume Next
With fDialog
.AllowMultiSelect = False
.Title = "Ablagepfad für pdf-Datei auswählen"
.Filters.Delete
.InitialFileName = "c:\Standardordner" & "\" 'Wichtig = "\"
result = .Show
GivePath = Trim(.SelectedItems.Item(1))
End With
path = GivePath
pattern = "*.txt"
file = Dir(path & pattern)
Do While file ""
xk = Sheets("x1").UsedRange.Rows.Count
Open path & file For Input As #1
Do While Not EOF(1)
Line Input #1, temp
Cells(xk, 1) = Replace(temp, VTab, ";")
xk = xk + 1
Loop
Close #1"
HIER FOLGT DANN NOCH WEITERER CODE ZUM VERARBEITEN DER AUSGELESENEN txt.Datei.
Besten Dank für eure Hilfe.
Grüße,Philipp

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub test() 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\" 'Wichtig = "\" .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 strFile = Dir Loop End If End With End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Private Sub test() 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\" 'Wichtig = "\" .Title = .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 '''hier kommt der code der die eingefüggte textdatei bearbeitet strFile = Dir Loop ''''ab hier hat der ursprüngliche code die nächste im Verzeichnis liegende txt _ datei bearbeitet End If End With End Sub

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

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

Beliebteste Forumthreads (12 Monate)

	A	B	C	D	E	F
1	Gruß Sepp
2
3

	A	B	C	D	E	F
1	Gruß Sepp
2
3

	A	B	C	D	E	F
1	Gruß Sepp
2
3

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread