merge files und import makro meldet fehler
06.02.2008 15:37:04
christian
vielleicht kann mir jemand helfen. mein folgendes makro funktioniert nicht in meinem excel dokument, obwohl die einzelnen schritte meiner meinung nach korrekt sind und einzeln funktionieren.
folgende schritte sollten durch das makro erstellt werden:
1. Im ordner "Datenordner" (bei mir auf dem Desktop) sollten alle txt dateien zu einer output.txt zusammengefügt werden.
2. die zusammengefügte datei soll in excel an "$C$1", "C:H" importiert werden. bei erneutem makrostart sollen die spalten "C:H" zuerst wieder gelöscht werden.
3. damit ich das makro mit kleiner anpassung auf jedem pc laufen lassen kann, habe ich ein excel register "MarcoValues" erstellt um die notwendigen pfadangaben einzulesen.
Sub Import_TXT_start()
Dim myPath As String
Dim myOutputFile As String
myPath = Range("MarcoValues!B2").Value
myOutputFile = Range("MarcoValues!B3").Value
'myPath = "C:\Datenordner\" 'wichtig: am Schluss muss ein \ stehen
'myOutputFile = "output.txt"
MergeFiles myPath, myOutputFile
Import_TXT myPath & myOutputFile, "$C$1", "C:H"
End
Sub
Sub MergeFiles(SourceFolder As String, OutputFile As String) 'Zusammenfügen nummerierter .txt _
Dateien in aufsteigender Richtung
Dim i As Integer
Dim Textzeile
Open SourceFolder & OutputFile For Output As #1
With Application.FileSearch
.LookIn = SourceFolder 'Wo suchen
.Filename = "*.txt" 'Was suchen
If .Execute > 0 Then 'Gefunden ?
For i = 1 To .FoundFiles.Count 'loopen durch alle gefundenen Files
'MsgBox .FoundFiles(i) 'Gibt Message Box mit gefundener Datei aus
If .FoundFiles(i) SourceFolder & OutputFile Then
Open .FoundFiles(i) For Input As #2 'Öffne gefundene Datei
Do While Not EOF(2) 'Schleife bis Dateiende.
Line Input #2, Textzeile 'Zeile in Variable einlesen.
Print #1, Textzeile 'Ausgabe im Datei.
Loop
Close #2
End If
Next i 'Nächste Datei
End If
End With
Close #2
Close #1
End
Sub
Sub Import_TXT(Filename As String, Position As String, DataRange As String)
Range(DataRange).Select
Selection.ClearContents
'MsgBox "DataRange: " & DataRange & " deleted!"
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Filename, Destination:=Range(Position))
.Name = Filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(6, 12, 9, 9, 9, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End
Sub
besten dank für eure hilfe
gruss christian