Anwendungs- oder objektdefinierter Fehler
Josef
Ich bekomme nach dem Start des Makros immer den Fehler Anwendungs- oder objektdefinierter Fehler.
Das Makro hatte bereits funktioniert . Ich hatte nur den Pfad geändert:
Im Ordner mit der Variable dokname3 befinden sich csv Dateien, welche dann eingelsen werden.
Wo könnte hier der Fehler bitte sein?
Danke
Josef
Sub CSV2XLS()
'Alle .txt (Trennzeichen ;) eines Ordners in .xls umwandeln
Dim oFS As Object, oFolder As Object, oFile As Object
Dim strFolder As String
Dim strTxt As String, myArr, lngL As Long, wks As Worksheet, iFREE As Integer
Dim dokname
Dim dokname2
Dim dokname3
Dim wks2 As Worksheet
Set wks2 = Workbooks("Import_Ersatz.xls").Worksheets("Tabelle1")
dokname = wks2.Range("Tabelle1!D1").Value
dokname2 = wks2.Range("Tabelle1!D2").Value
dokname3 = wks2.Range("Tabelle1!F3").Value
If Dir("K:\Allg_dat\TRANSFER\HST\ABT08\" & dokname2 & dokname & "\" & dokname3 & "\") "" _
Then
With Application.FileDialog(4)
.InitialFileName = "K:\Allg_dat\TRANSFER\HST\ABT08\" & dokname2 & dokname & "\" & _
dokname3 & "\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Else
MsgBox "Der Ordner wurde noch nicht angelegt"
Exit Sub
End If
Workbooks.Add
Sheets("Tabelle3").Select
Sheets.Add
Sheets("Tabelle4").Select
Sheets("Tabelle4").Move After:=Sheets(4)
Sheets("Tabelle4").Select
Sheets("Tabelle4").Name = "Rest"
On Error GoTo FEHLER
DoEvents
GetMoreSpeed
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder(strFolder)
iFREE = FreeFile
For Each oFile In oFolder.Files
If oFile.Name Like "*.csv" Then
Set wks = Worksheets.Add
wks.Name = Left(oFile.Name, 25)
lngL = 1
Open oFile For Input As iFREE
'Do Until EOF(iFREE)
' Line Input #iFREE, strTxt
' myArr = Split(strTxt, ";")
' For I = 0 To UBound(myArr)
' myArr(I) = Trim(myArr(I))
' Next
' With WKS
' .Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
' End With
' lngL = lngL + 1
'Loop
Do Until EOF(iFREE)
Line Input #iFREE, strTxt
myArr = Split(strTxt, ";")
With wks
.Range(.Cells(lngL, 1), .Cells(lngL, UBound(myArr) + 1)) = myArr
End With
lngL = lngL + 1
Loop
Close #iFREE
End If
Next oFile
Call Umbenennen
Call Format
Call Zeichenkorrektur
Call DS_Löschen
Call Bundeslandzahl
Call Verarbeitung_Oesterreich
Call Korrektur
Call Ueberschriften
Call Verarbeitung_Rest
AUFRAEUMEN:
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
GetMoreSpeed False
Exit Sub
FEHLER:
If Err.Number Then
MsgBox "Fehler!" & vbLf & Err.Description
Err.Clear
Resume AUFRAEUMEN
End If
End Sub