AW: ...bis auf ein Mysterium läufts
10.09.2005 23:27:40
Josef
Hallo Michael!
Zu 1.)
Schau dir mal "TextToColumns" in der OH an, da ist das ganze recht gut erklärt!
Zu 2.)
Die FileSearch Methode sortiert alle gefundenen Dateien entweder auf- oder
absteigend. Da wird nicht zwischen den einzelnen Ordnern unterschieden!
Probier mal diesen Code, dann sollte die Reihenfolge stimmen.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private lRow As Long
Private fso, fo, fu
Private arrFiles() As String
Private n As Integer
Sub Multi_Text_Import()
Dim strTemp As String
Dim wks As Worksheet
Dim iFile As Integer
lRow = 1 'Startzeile in der Tabelle
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Erase arrFiles
n = 0
iFile = FreeFile
Set wks = ActiveSheet 'Oder: Set wks = Sheets("Tabellenname")
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.getfolder(ThisWorkbook.Path)
If getFiles(fo, "txt", True) <> 0 Then
With wks
.Cells.Clear
For n = LBound(arrFiles) To UBound(arrFiles)
.Cells(lRow, 1) = fso.GetParentFolderName(arrFiles(n))
lRow = lRow + 1
.Cells(lRow, 1) = fso.getbasename(arrFiles(n))
lRow = lRow + 1
Open arrFiles(n) For Input As #iFile
Do While Not EOF(iFile)
Input #iFile, strTemp
.Cells(lRow, 1) = strTemp
lRow = lRow + 1
Loop
Close #iFile
lRow = lRow + 1
Next
End With
'Text in Spalten:
'Trennzeichen ggf. anpassen!
wks.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1))
wks.Columns.AutoFit
End If
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Function getFiles(pF, sExt As String, Optional SearchSubFolders As Boolean = False) As Long
Dim f
For Each f In pF.Files
If fso.getextensionname(f) = sExt Then
Redim Preserve arrFiles(n)
arrFiles(n) = f
n = n + 1
getFiles = -1
End If
Next
If SearchSubFolders Then
For Each fu In pF.subfolders
getFiles fu, sExt, SearchSubFolders
Next
End If
End Function
Zum Mysterium kann ich nur sagen, das ich im Moment keine Idee habe,
warum und wie das Makro die textdateien verändern sollte!
Gruß Sepp
P.S.: Rückmeldung nicht vergessen!