Laufzeitfehler 1004 in If- Schleife

Question

Hallo zusammen,

ich möchte Daten aus *.csv- ähnlichen Dateien importieren. Die Endung der Dateien variiert. Dadurch ändert sich auch das "Importierverfahren" (Tabstop, Komma, Semikolon, "="...).
Hierzu verwende ich eine If- Abfrage, so dass ich für jede Dateiendung das passende Trennzeichen verwende.
Das hat soweit funktioniert doch als ich in die funktionierende If- Schleife einen zusätzlichen Vorgang integriert habe (das Tabellenblatt "Vorlage" auswählen, Zellen kopieren, im Tabellenblatt "c" einfügen und dann den importierten Datensatz überschreiben ==> s.u., abgesetzt) habe ich beim Debuggen den Laufzeitfehler 1004 erhalten: "Die Selekt- Methode des Range Objektes konnte nicht ausgeführt werden". Ich habe hier schon etwas gestöbert, die Excel- Hilfe hinzugezogen, konnte aber bisher noch keine Lösung für mein Problem finden. Ich verwende Excel 2003.
Hat jemand einen Vorschlag?

Vielen Dank vorab für eine konstruktive Rückinfo.

Hier der relevante Auszug aus dem Quelltext:


ElseIf ccc = "cia" Then

' 3) "cia"

With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
.Name = c
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=False



Sheets("Vorlage").Select
Range("B1:C500").Select
Selection.Copy
Sheets(c).Select
Range("B1").Select
ActiveSheet.Paste
Range("B1:C500").Select
Application.CutCopyMode = False
Selection.Copy
Range("D1:E500").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("A:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("A:C").EntireColumn.AutoFit
Columns("A:C").EntireColumn.AutoFit
Range("A1").Select
End With

ElseIf ccc = "aca" Then

' 4) "aca"

VG, Bernd

Answer 1

Hallo!

Ich sehe da nicht von eine IF-Aufteilung auf die Endungen und Trennern noch davon wie Daten aus Dateien gezogen werden?!

Zunächst mal rate ich da zu dir mal SELECT-CASE anzusehen. Aus der Hand hingeschrieben:
DateiTyp=Ucase(HabeIchIrgedwoHerbekommen)
Select Case DateiTyp
Case "TXT"
Trenner=Chr(9)'Tab
Case "CSV"
Trenner=","
Case "DAT
Trenner=";"
End Select
Das ist übersichtlicher als IF-Sequenzen. (Die Variablen sind alle Typ String.)

Eine Datei öffne ich dann mit OPEN und lese sie Zeile um Zeile ein (LINE INPUT). Das bisschen Stringakrobatik diese dann zu zerteilen hast du sicherlich schon.
Schließlich schreibe ich diese Rückgaben aus Variablen direkt in Zielzellen {schlimmstenfalls WorkBooks("Hans.Xls").WorkSheets("Klaus").Cells(X,Y) als direkte Referenzierung} wobei ich Zählvariablen einsetze, DO-LOOP und Zeilenwiese ggf. FOR-TO-NEXT.

Dieser ganze Select-Krimskrams stammt vom Makroeditor, richtig? Da ist er Weltspitze drin, nur sind diese Klimmzüge völlig überflüssig. Nur wenn ich dem Benutzer eine Blatt und eine Zelle auf Auge drücken will ist SELECT nötig, sonst nicht.
Columns("A:C").EntireColumn.AutoFit
Columns("A:C").EntireColumn.AutoFit
ist offensichtlich doppelt, und all diesen Kopierne und Einkleben geht über direkte Zellzuweisungen viel handzahmer und ohne Zerstörung des Inhalts der Zwischenablage.

Ich schlage vor du postest den ganzen Code, und kapsele ihn bitte (was ich oben nicht getan habe) mit der dafür vorgesehen Funktion - sieh oben die Schaltfläche «Code» in die im editierbaren Text der Code eine Konstruktion wie [kode][/kode] geklebt wird.

Eric March

Answer 2

Hallo Eric,

vielen Dank erstmal für deine Antwort. Dein Ansatz ist interessant, leider kann ich mir im VBA- Editor nur ein paar Dinge zusammen flicken (If, For- Schleifen) aber vieles zeichne ich auf und ändere es ab ==> so auch hier.
Ich habe die zu importierenden Dateien in einem Ordner liegen in dem auch meine Excel Datei liegt. Mit einem ersten Makro lasse ich mir die Dateien als Pfad im Sheet "Input" auflisten. Anschließend filtere ich den Dateinamen aus dem Pfad sowie deren Endung (pfm, cia, cca...).
Das klappt. Mein drittes Makro (jenes hier) fügt für jede Datei ein Tabellenblatt ein, der Name der Datei wird dabei dem jeweiligen Tabellenblatt zugewiesen. Das klappt auch, wenn ich diesen Part weglasse:

 Sheets("Vorlage").Range("A1").Select
        Range("B1:C500").Select
        Selection.Copy
        Sheets(c).Select
        Range("B1").Select
        ActiveSheet.Paste
        Range("B1:C500").Select
        Application.CutCopyMode = False
        Selection.Copy
        Range("D1:E500").Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        Columns("A:C").Select
        Application.CutCopyMode = False
        Selection.Delete Shift:=xlToLeft
        Columns("A:C").EntireColumn.AutoFit
        Columns("A:C").EntireColumn.AutoFit
        Range("A1").Select
        End With


Diesen Part benötige ich, da ich beim Einlesen der Datei immer Datumswerte bekomme wo ich keine haben will (z.B.: Versionsnummer in einer Datei: 1.1.7  ==> wird automatisch 01.01.2007 etc.). Habe versucht alles als Text einzufügen, habe die Spalte vorher markiert und als Text formatiert ==> hilft alles nix.
Meine Idee war die Datei mit der Endung *.cia ohne Trennung einzufügen (Trenner wäre das "ISTGLEICH". Sobald die Spalte im neuen Tabellenblatt eingefügt ist, sollen aus dem Sheet "Vorlage" die Formeln aus Zelle B1:C:500 kopiert und im aktuellen Tabellenblatt (Variable c) wieder eingefügt werden. Die beiden Formeln sehen so aus:

B1:B500  ==>  =WENN(A1="";"";WENN(ISTFEHLER(FINDEN("=";A1));A1;LINKS(A1;(FINDEN("=";A1)-1))))

Vereinfacht: Wenn in Spalte A nichts steht, mach nichts, sonst prüfe ob es ein "=" gibt, wenn ja, dann den Text bis zum "=" kopieren, wenn nein, einfach den Text ganzen kopieren!

==> Daraus ergibt sich die Bezeichnung!

C1:C500 ==>  =WENN((LÄNGE(A1)-LÄNGE(B1))=0;"";RECHTS(A1;LÄNGE(A1)-LÄNGE(B1)-1))

==> Daraus resultiert der Wert der Bezeichnung!

Beisiel:
Bezeichnung: "Version" in Zelle B4
Wert : "1.1.7" in Zelle C4

So will ich es haben. Anschließend will ich das ganze kopieren in Spalte D:E und die ersten 3 Spalten löschen!

Vielleicht gibt es auch einen Trick wie man sicherstellt dass nur Text eingefügt wird. Dann bräuchte ich diesen Part nicht und das Problem wäre elegant umgangen.
Ansonsten hätte ich hier den ganzen Quellcode des Makros:

Private Sub CommandButton3_Click()
    Dim proof As Integer
    proof = Sheets("Input").Range("A11")
    If proof = 3 Then
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Range("A15:F16").Select
    With Selection.Interior
    .ColorIndex = 15
    .Pattern = xlSolid
    End With
    Blätter = Sheets("Input").Range("C13")
    Dim c As String
    Dim cI As String
    Dim ccc As String
    Dim ze As Long 'Zeilennummer für Einfügen
    Dim sp As Integer 'Spaltennummer für Einfügen
    Dim zeI As Long 'Zeilennummer für importieren
    Dim spI As Integer 'Spaltennummer für importieren
    Dim zeIF As Long 'Zeilennummer für Wenn- Bedingung
    Dim spIF As Integer 'Spaltennummer für Wenn- Bedingung
    Dim y As Long
    For y = 1 To Blätter
    ze = 16 + y
    sp = 6
    zeI = 16 + y
    spI = 1
    zeIF = 16 + y
    spIF = 4
    c = Cells(ze, sp)
    cI = Cells(zeI, spI)
    ccc = Cells(zeIF, spIF)
    Sheets.Add.Name = c
    Move before:=Sheets("Input")
    Sheets(c).Activate
        
        If ccc = "pfo" Then
        
        ' 1) "pfo"
        
        With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
        .Name = c
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierNone
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "="
        .TextFileColumnDataTypes = Array(1, 1)
        .Refresh BackgroundQuery:=False
        End With
        
         ElseIf ccc = "pfm" Then
         
         ' 2) "pfm"
         
        With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
        .Name = c
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "="
        .TextFileColumnDataTypes = Array(1, 1)
        .TextFileDecimalSeparator = "."
        .TextFileThousandsSeparator = " "
        .Refresh BackgroundQuery:=False
        End With
        
         ElseIf ccc = "cia" Then
         
         ' 3) "cia"
         
         With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
        .Name = c
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierNone
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnData

Answer 3

Hallo Eric,
Hallo zusammen,

habe inzwischen eine Lösung für mein ursprüngliches "Datumproblem" gefunden. Hatte schlichtweg die Spalte nicht markiert (das muss man vorher mal wissen ;-)).
Dennoch wäre es schön wenn jemand eine Antwort auf meine Frage mit dem Laufzeitfehler in der Schleife hätte (das werde ich später nochmal benötigen, nur in anderer Form).

Vielen Dank für all die Einträge die mir schon des öfteren weitergeholfen haben.

VG, Bernd

Answer 4

Hallo!

Da muss ich noch mal durch, in aller Ruhe… Genug Code ist redundant und (wie ich erwähnte) so typisch Makrorecorder, dass einem die Tränen kommen.


Schau dir bitte diese beiden Blöcke an die ich willkürlich gegriffen und eingeklebt habe. Den oben direkt, den unteren in die basagten (sog.) Code-Tags [ c o d e ] … [ / c o d e ]. Fällt dir der Vorteil der Einrückung und Lesbarkeit auf? Führende Leerzeichen werden von der Forensoftware entfernt.

--------
Sub basteln()
Dim I As Integer
Dim J As Integer
Dim Wert As String
Dim z As Integer

z = 12
I = 0
Do
I = I + 1
For J = 1 To 8
Wert = Worksheets(1).Cells(J, I).Value
If Wert = "m" Or Wert = "n" Then Wert = "0"
Worksheets(1).Cells(z, J) = Wert
Next
z = z + 1
Loop Until Wert = ""
End Sub
-------

Sub basteln()
Dim I As Integer
Dim J As Integer
Dim Wert As String
Dim z As Integer

z = 12
I = 0
Do
I = I + 1
For J = 1 To 8
Wert = Worksheets(1).Cells(J, I).Value
If Wert = "m" Or Wert = "n" Then Wert = "0"
Worksheets(1).Cells(z, J) = Wert
Next
z = z + 1
Loop Until Wert = ""
End Sub

-------

Eric March

Answer 5

Hier der ein wenig eingedampfte Code (der laufen sollte)

Private Sub CommandButton_3.Click()

Dim proof As Integer
Dim c As String
Dim cI As String
Dim ze As Long 'Zeilennummer für Einfügen
Dim sp As Integer 'Spaltennummer für Einfügen
Dim zeI As Long 'Zeilennummer für importieren
Dim spI As Integer 'Spaltennummer für importieren
Dim zeIF As Long 'Zeilennummer für Wenn- Bedingung
Dim spIF As Integer 'Spaltennummer für Wenn- Bedingung
Dim y As Long
Dim Blätter As String


proof = Sheets("Input").Range("A11")
'Wo befinden wir uns wenn nicht auf Blatt "Input"?

If proof = 3 Then
Columns("A:F").EntireColumn.AutoFit
With Range("A15:F16").Interior
.ColorIndex = 15
.Pattern = xlSolid
End With

Blätter = Sheets("Input").Range("C13")

For y = 1 To Blätter
ze = 16 + y
sp = 6
zeI = 16 + y
spI = 1
zeIF = 16 + y
spIF = 4
c = Cells(ze, sp)
cI = Cells(zeI, spI)
Sheets.Add.Name = c
Move before:=Sheets("Input")

Select Case Cells(zeIF, spIF)

Case "pfo"
With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
'Damit habe ich noch nie gebastelt. Braucht man zwangweise alle Attribute?
'Bei Range("A15:F16").Interior z.B. kann man noch vieles mehr quasi leer mit angeben.
.Name = c
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "="
.TextFileColumnDataTypes = Array(1, 1)
.Refresh BackgroundQuery:=False
End With

Case "pfm"
With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
.Name = c
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "="
.TextFileColumnDataTypes = Array(1, 1)
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = " "
.Refresh BackgroundQuery:=False
End With

Case "cia"
With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1"))
.Name = c
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=False

With Worksheets("Vorlage")
Worksheets(c).Range("B1:C500").Value = .Range("B1:C500").Value
.Range("D1:E500").Value = .Range("B1:C500").Value
End With

'Ich mag zwar diese Angaben mit Buchstaben nicht, aber hier ist es praktischer.
Columns("A:C").Delete
Columns("A:C").EntireColumn.AutoFit
Range("A1").Select
End With

Case Else
MsgBox "Dateityp unbekannt! Importieren nicht möglich!"

End Select

Columns("A:L").EntireColumn.AutoFit
Next 'y

Sheets("Input").Activate
Range("A15").Select
'Wir sind jetzt immer noch auf dem neuen Blatt?!
Sheets("Input").Range("A11").Value = proof + 1
Else
MsgBox "Schrittkette noch nicht erreicht oder Dateien bereits importiert!"
End If
End Sub

Answer 6

Hallo Eric,

vielen Dank für deine Antwort.
Wie von dir scheinbar erahnt gibt es Probleme im Ablauf an folgender Stelle:

With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1")).Name = c

'Damit habe ich noch nie gebastelt. Braucht man zwangweise alle Attribute?
'Bei Range("A15:F16").Interior z.B. kann man noch vieles mehr quasi leer mit angeben.

Ich bekomme folgende Fehlermeldung:

"Der Zielbereich befindet sich nicht auf der Tabelle, auf der die Abfragetabelle erstellt wurde."

In der IF- Schleife funktioniert das!

Ich will damit sagen, füge ein neues Tabellenblatt ein (Quelle cI ==> vollständiger Pfad) und benenne das Tabellenblatt (Quelle c ==> Teil des Pfades.

VG

Answer 7

Hallo Bernd06!

Wie ebne gesagt, damit kenne ich mich nicht aus, mit diesen Abfragetabellen in Blättern - ich hatte nie damit zu tun und sie auch nie vermisst.

With ActiveSheet.QueryTables.Add(Connection:="Text;" & cI, Destination:=Sheets(c).Range("A1")).Name = c

Warum du eine solche Abfrage dem Blatt hinzufügen willst. das musst du wissen. Ob die fett gesetzten Stellen die Stolpersteine sind kann ich nicht sagen ohne alle Quelldaten und -dateien drumrum; aber ich vermute es mal.
Von meiner bescheidenen Warte aus würde ich stupide ein Blatt hinzufügen und benennen, dann einfach mit der Eingangs erwähnten schnöde OPEN-Methode die Quelldatei auslesen und dort eintragen, und schließlich Daten auswerten und umschichten.

Vielleicht aber muss und hier ein andere mal beispringen der sich damit besser auskennt. Wo hast du denn diesen Codeschnipsel her; ist das Aufgezeichnetes was du verändert hast?

Eric March

Answer 8

Hallo Eric,

es ist eine Kombination aus aufgezeichnet und gebastelt. Ein bißchen logisch denken ist schon drin, allerdings habe ich von Programmieren an sich keine Ahnung (vor allem von der Syntax). Aber bisher konnte ich in Excel alles darstellen.
Meine nächste If- Schleife ersetze ich mit Select.Case. Sie hätte insgesamt 23 Fälle wobei es eigentlich nur 4 Anweisungen für die Fälle gibt.

Ich danke dir trotzdem für deine Zeit die du hier geopfert hast und ich werde auf jeden Fall ein Feedback senden ob es geklappt hat.

Dir einen schönen Abend.

Gruß, Bernd