CSV nach XLS

Hallo zusammen,
ich habe ein für mich sehr komplexes Problem zu lösen.
Im Verzeichnis G:\csv stehen x csv-Datei en mit identischem Aufbau.
Diese sollen nun in 1 xls-Datei mit allen Datensätzen zusammengefasst
werden und in G:\xls gespeichert werden. Mittels Hilfe aus dem Forum
habe ich nunmehr eine Teillösung realisiert, die die csv-Dateien in
einezelne xls-Dateien automatisiert umwandeln soll:
-------------------------------------------------------------------


Sub scanner()
Dim dName$
dName = "g:\csv\*.csv"
If Dir(dName) <> "" Then
umwandeln
Else
Application.Quit
End If
End 

Sub

Sub umwandeln()
'einlesen der ermittelten csv datei
Dim DatVgl As Date
Dim Mappe As String
Dim ZMappe As String
Const m = "g:\csv"
Mappe = Dir(m & "\*.csv")
Do Until Mappe = ""
DatVgl = FileDateTime(m & "\" & Mappe)
Dat = DatVgl
ZMappe = m & "\" & Mappe
Mappe = Dir()
Loop
Application.Visible = False
Workbooks.Open Filename:=ZMappe
Application.Visible = False
'datei wird als kopie in unterordner verschoben
Dim s As String
Const Lw = "g:\"
Const Pfad = "g:\xls"
'Ermitteln des Dateinamens
s = ActiveWorkbook.Name
ChDrive Lw
ChDir Pfad
'Arbeitsmappe speichern
ActiveWorkbook.SaveAs Filename:=s, FileFormat:=xlExcel8, Password:="",
WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Zuvor bearbeitete Datei wird aus Hauptverzeichniss gelöscht
On Error GoTo ende:
ChDir "g:\csv"
Kill (s)
ende:
'erneutes starten des scanners
scanner
End 

Sub
Die Quell-Dateien sehen wie folgt aus:
Quelle01.csv
Typ; Datum; Name; Rufnummer; Nebenstelle; Eigene Rufnummer; Dauer
1;31.12.06 17:04;;093485858686;Telefon;Festnetz;0:04
1;31.12.06 15:47;;unbekannt;Telefon;Festnetz;0:02
Quelle02.csv
Typ; Datum; Name; Rufnummer; Nebenstelle; Eigene Rufnummer; Dauer
1;02.08.06 20:01;;unbekannt;Telefon;Festnetz;0:01
1;02.08.06 18:14;;0699785433;Telefon;Festnetz;0:03
3;02.08.06 15:21;Meier R;2671;Telefon;Internet: 837677;0:05
Die Ziel-Datei sollte wie folgt aussehen:
Ziel.xls
Typ Datum            Name    Rufnummer    Nebenstelle Eigene Rufnummer Dauer
1   31.12.2006 17:04         093485858686 Telefon     Festnetz         00:04
1   31.12.2006 15:47         unbekannt    Telefon     Festnetz         00:02
1   30.12.2006 20:01         unbekannt    Telefon     Festnetz         00:01
1   30.12.2006 18:14         0699785433   Telefon     Festnetz         00:03
3   30.12.2006 15:21 Meier R 2671         Telefon     Internet: 837677 00:05
Das tatsächliche Ergebins ist jedoch:
Typ; Datum; Name; Rufnummer; Nebenstelle; Eigene Rufnummer; Dauer
1;31.12.06 17:04;;093485858686;Telefon;Festnetz;0:04
1;31.12.06 15:47;;unbekannt;Telefon;Festnetz;0:02
1;02.08.06 20:01;;unbekannt;Telefon;Festnetz;0:01
1;02.08.06 18:14;;0699785433;Telefon;Festnetz;0:03
3;02.08.06 15:21;Meier R;2671;Telefon;Internet: 837677;0:05
Was mache ich falsch ?
mfg
Jürgen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: CSV nach XLS

30.01.2007 05:47:41

Ramses

AW: CSV nach XLS

30.01.2007 08:30:06

Jürgen

AW: CSV nach XLS

30.01.2007 11:28:34

Ramses

AW: CSV nach XLS

30.01.2007 19:58:58

Jürgen

AW: CSV nach XLS

01.02.2007 23:04:39

Horst

AW: CSV nach XLS

02.02.2007 08:21:12

Ramses

AW: CSV nach XLS

02.02.2007 08:19:46

Ramses

Sub Convert_CSV_to_XLS() Dim i As Long, totFiles As Long Dim gefFile As String, gefName As String Dim srcPfad As String, conFile As String Dim secPfad As String, secFile As String Dim bacPfad As String Dim oldStatus As Variant Dim myFSO As Object, myTar As String Set myFSO = CreateObject("scripting.filesystemobject") 'Dateitypen definieren conFile = "csv" secFile = "xls" 'Pfadangaben mit Backslash am Ende 'srcPfad = Hier sind die CSV Dateien srcPfad = "G:\csv\" 'bacPfad = Hier werden die CSV-Sicherheitsdateien gespeichert bacPfad = "G:\csv\csv_conv_to_xls\" 'secPfad = Hier sollen die XLS Dateien hin secPfad = "G:\xls\" Application.ScreenUpdating = True oldStatus = Application.StatusBar With Application.FileSearch .LookIn = srcPfad .SearchSubFolders = True .Filename = "*." & conFile If .Execute() > 0 Then totFiles = .FoundFiles.Count Application.StatusBar = "Total " & totFiles & " gefunden" For i = 1 To .FoundFiles.Count gefFile = .FoundFiles(i) Application.Workbooks.Open gefFile 'Spalte konvertieren Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Semicolon:=True 'Speichern im Zielordner With ActiveWorkbook .SaveAs secPfad & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 3) & secFile, True .Close , True End With 'Sicherheitsdatei erstellen 'Prüfen ob Sicherungsorder besteht If Not myFSO.folderexists(bacPfad) Then MkDir bacPfad End If 'CSV-Datei verschieben myFSO.MoveFile gefFile, bacPfad Next i End If End With MsgBox i & " CSV-Dateien konvertiert ", vbInformation + vbOKOnly, "Fertig" Application.StatusBar = oldStatus Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread