AW: Konvertieren von Dateien
04.03.2011 17:59:20
Dateien
Hallo,
habe mal was zusammengestellt, kannst ja mal testen.
Pfad wo die Dateien liegen noch anpassen.
Ich gehe mal davon aus das die Daten in der Datei in der ersten Tabelle stehen.
Option Explicit
Sub Start()
Dim oApp As Excel.Application
Dim varFile, ArrayInhalt(), ArrayFile
Dim A&, B&
Dim strString$, strOrdner$
Dim iCalc As Integer
Dim ArrTrenn(1 To 2)
'Pfad wo die Dateien liegen
strOrdner = "C:\Ordner mit Excel-File"
'Dateien im Ordner Suchen
'Array, Pfad Ordner, Filter
FindFiles ArrayFile, strOrdner, "*.xls"
If Not IsArray(ArrayFile) Then
MsgBox "Keine Dateien gefunden", vbExclamation
Exit Sub
End If
With Application
iCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
'Trennzeichen, 1 = Semikolon - 2 = Zeilenumbruch
ArrTrenn(1) = ";": ArrTrenn(2) = vbCrLf
Set oApp = New Excel.Application
With oApp
.DisplayAlerts = False
.EnableEvents = False
For Each varFile In ArrayFile
'Datei Schreibgeschützt öffnen
With .Workbooks.Open(varFile, ReadOnly:=True)
'erste Tabelle in File
With .Sheets(1)
ArrayInhalt = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value2
'Überschrift
strString = ArrayInhalt(1, 1) & ArrTrenn(1)
strString = strString & ArrayInhalt(1, 2) & ArrTrenn(2)
'Zahlen aus Spalte A u. B in der ersten Tabelle
For A = 2 To Ubound(ArrayInhalt)
For B = 1 To Ubound(ArrayInhalt, 2)
If IsNumeric(ArrayInhalt(A, B)) Then
'Zahlen auf vier Nachkommastellen runden
ArrayInhalt(A, B) = CStr(Round(ArrayInhalt(A, B), 4))
End If
'String zusammenführen, Komma in Punkt wandeln
strString = _
strString & Replace(ArrayInhalt(A, B), ",", ".") & ArrTrenn(B)
Next B
Next
End With
.Close False
End With
'CSV mit dem Inhalt erstellen
Erstelle_CSV Left$(varFile, InStrRev(varFile, ".") - 1) & "_n.csv", strString
Next varFile
.DisplayAlerts = True
.EnableEvents = True
End With
oApp.Quit
Set oApp = Nothing
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub FindFiles(ByRef ArrayFile, ByVal strPath$, strFilter$)
Dim nCount As Long, tmpFile$, tmpArray()
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
On Error GoTo ErrorH
ChDrive Left$(strPath, 2)
ChDir strPath
tmpFile = Dir$(strPath & strFilter, vbNormal)
Do While tmpFile <> ""
If tmpFile Like strFilter Then
Redim Preserve tmpArray(nCount)
tmpArray(nCount) = strPath & tmpFile
nCount = nCount + 1
End If
tmpFile = Dir$()
Loop
If nCount > 0 Then ArrayFile = tmpArray
Exit Sub
ErrorH:
MsgBox Err.Description, vbCritical + vbMsgBoxHelpButton, "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Sub Erstelle_CSV(ByVal strFullName$, ByRef strInhalt$)
Dim F As Integer
F = FreeFile
Open strFullName For Output As #F
Print #F, strInhalt
Close #F
strInhalt = ""
End Sub
PS: Deine erste Datei ist bei mir leer.
Gruß Tino