AW: Inhalt von 12 versch. csv-Dateien in eine xls-Date
12.07.2013 14:41:31
12
Hallo Ronald,
zu 1.
hier hab ich einen Parameter geändert, so dss jetzt der Windowssystemzeichensatz verwendet wird statt 850.
zu 2.
bei mir kommen auf Grund welcher Einstellung auch immer die Dateinamen immer nach Name sortiert raus.
Ich hab das Einlesen der Namen modiefiert und eine Sortierroutine für 1-spaltige Datenarrays hinzugefügt.
Gruß
Franz
Sub CSV_Import()
Dim strPfad As String
Dim lngLastRow As Long
Dim myFileSystemObject, myFiles, arrFiles(), intFile As Integer
' Pfad hier anpassen
strPfad = "C:\Users\Holz.DIAKOSO\Desktop\CSV-Import\"
strPfad = "D:\Test\DatenNeu\"
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
'CSV-Dateien in Array einlesen
For Each myFiles In myFileSystemObject.GetFolder(strPfad).Files
If InStr(UCase(myFiles), ".CSV") Then
intFile = intFile + 1
ReDim Preserve arrFiles(1 To intFile)
arrFiles(intFile) = myFiles
End If
Next
Set myFileSystemObject = Nothing
'Array mit Dateinamen sortieren, wenn mehr als 1 Datei
If intFile > 1 Then Call QuickSort(VA_array:=arrFiles)
If intFile = 0 Then
MsgBox "Keine CSV-Dateien im Ordner " & strPfad
Exit Sub
End If
For Each myFiles In arrFiles
With ActiveSheet.UsedRange
lngLastRow = .Row + .Rows.Count
If lngLastRow = 2 Then lngLastRow = 1
End With
'Die nächsten beiden Zeilen weglassen, wenn der Dateiname nicht in der Liste _
erscheinen soll
ActiveSheet.Cells(lngLastRow, 1) = myFiles
lngLastRow = lngLastRow + 1
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myFiles, Destination:=ActiveSheet.Cells(lngLastRow, 1))
.Name = myFiles
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows 'Korrektur war 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next myFiles
Erase arrFiles
End Sub
Public Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
On Error Resume Next
Dim V_Low2, V_high2, V_loop As Integer
Dim V_val1, V_val2 As Variant
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_array, 1)
End If
If IsMissing(V_high1) Then
V_high1 = UBound(VA_array, 1)
End If
V_Low2 = V_Low1
V_high2 = V_high1
V_val1 = VA_array((V_Low1 + V_high1) / 2)
While (V_Low2 V_val1 And _
V_high2 > V_Low1)
V_high2 = V_high2 - 1
Wend
If (V_Low2 V_Low1) Then Call _
QuickSort(VA_array, V_Low1, V_high2)
If (V_Low2