08.03.2019, 12:07
Hallo liebes Excel-Forum.
Mein Programm läuft fast, es verbleibt ein kleiner bug.
Wenn ich neue Blätter (Sheets) einfüge, werden alle Werte in Spalten größer 3 (also d und Fortfolgende) gelöscht.
Sieht Jemand, warum das so ist?
'_________________________
'ERFASSEN tatsächlich vorhandener Dateien
Dim wbCSV As Workbook
Dim wbAUSWERTUNG As Workbook
Dim ws As Worksheet
Dim WSNumber As Integer
Set fso = CreateObject("Scripting.Filesystemobject")
Set wbAUSWERTUNG = ActiveWorkbook
Application.DisplayAlerts = False
'Alle älteren Datenblätter löschen vorher
For i = 1 To wbAUSWERTUNG.Worksheets.Count
If i > 3 Then
wbAUSWERTUNG.Worksheets(i).Delete
End If
Next
'____________________
'Jetzt einlesen. ES WERDEN ALLE SPALTEN > 3 GELÖSCHT!!! muss repariert werden
'--------------------
For Each f In fso.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbCSV = ActiveWorkbook
On Error Resume Next
Set ws = wbAUSWERTUNG.Worksheets(f.Name)
If Err <> 0 Then
Set ws = wbAUSWERTUNG.Worksheets.Add(after:=Sheets(Sheets.Count))
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If
wbCSV.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbCSV.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbCSV.Close False
End If
Next
Application.DisplayAlerts = True
Set fso = Nothing
______________________
Vielen lieben Dank für Hinweise!
Mein Programm läuft fast, es verbleibt ein kleiner bug.
Wenn ich neue Blätter (Sheets) einfüge, werden alle Werte in Spalten größer 3 (also d und Fortfolgende) gelöscht.
Sieht Jemand, warum das so ist?
'_________________________
'ERFASSEN tatsächlich vorhandener Dateien
Dim wbCSV As Workbook
Dim wbAUSWERTUNG As Workbook
Dim ws As Worksheet
Dim WSNumber As Integer
Set fso = CreateObject("Scripting.Filesystemobject")
Set wbAUSWERTUNG = ActiveWorkbook
Application.DisplayAlerts = False
'Alle älteren Datenblätter löschen vorher
For i = 1 To wbAUSWERTUNG.Worksheets.Count
If i > 3 Then
wbAUSWERTUNG.Worksheets(i).Delete
End If
Next
'____________________
'Jetzt einlesen. ES WERDEN ALLE SPALTEN > 3 GELÖSCHT!!! muss repariert werden
'--------------------
For Each f In fso.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbCSV = ActiveWorkbook
On Error Resume Next
Set ws = wbAUSWERTUNG.Worksheets(f.Name)
If Err <> 0 Then
Set ws = wbAUSWERTUNG.Worksheets.Add(after:=Sheets(Sheets.Count))
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If
wbCSV.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbCSV.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbCSV.Close False
End If
Next
Application.DisplayAlerts = True
Set fso = Nothing
______________________
Vielen lieben Dank für Hinweise!