csv-Eexport Feldeigenschaften einstellen

13/08/2010 - 15:44 von Peter | Report spam
Hallo NG,

ich importiere Daten aus csv-Dateien, lege als Feldformat "Text" fest
und möchte wieder in eine csv-Datei exportieren. Hier wird das
Feldformat jedoch in "Standard" umgewandelt, soll aber "Text" bleiben.
Hier der Code für den Export:

Sub SaveCSV()
Sheets("Tabelle1").Activate
Dim Bereich As Object, Zeile As Object, Zelle As Object
Dim strTemp As String
Dim newFileName As String
newFileName = Sheets("Tabelle2").Cells(4, 4).Value

Const Pfad As String = "T:\Daten\"
Const Extension As String = ".CSV"
Const Trennzeichen As String = ";"

Set Bereich = Sheets("Tabelle1").UsedRange

Open Pfad & newFileName For Output As #1

For Each Zeile In Bereich.Rows
For Each Zelle In Zeile.Cells
If InStr(1, Zelle.Text, ";") > 0 Then
'Zellen, die ein Semikolon beinhalten in Anführungsstriche
setzen
strTemp = strTemp & """" & CStr(Zelle.Text) & """" &
Trennzeichen
Else
strTemp = strTemp & CStr(Zelle.Text) & Trennzeichen
End If
Next
Print #1, strTemp
strTemp = ""
Next

Close #1
Set Bereich = Nothing

Range("A1:IV65536").Delete

Sheets("Tabelle2").Activate

End Sub



Habt ihr einen Tipp?

Besten Dank,
Peter
 

Lesen sie die antworten

#1 Andreas Killer
13/08/2010 - 19:22 | Warnen spam
Am 13.08.2010 15:44, schrieb Peter:

Hier der Code für den Export:


...
Habt ihr einen Tipp?


Jipp. .-)

Andreas.

Sub Example_RangeToCSV()
Dim fso As Object 'FileSystemObject
Dim T As Object 'TextStream
Dim Separator As String

'Get the separator from your country settings
Separator = Application.International(xlListSeparator)

'Install errorhandler, file creation may fail
On Error GoTo ErrorHandler

'Create a CSV-file
Set fso = CreateObject("Scripting.FileSystemObject")
Set T = fso.CreateTextFile("C:\temp\test.csv")
'Write all data from current sheet
T.WriteLine RangeToCSV(ActiveSheet.UsedRange, Separator)
'Close the CSV
T.Close
'Done
Exit Sub

ErrorHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub

Function RangeToCSV(R As Range, _
Optional Separator As String = ";", _
Optional TextQualifier As String = """") As String
'Create CSV-string from range, range can contain areas
Dim Data, TempRow, TempCol, TempArea
Dim Area As Range
Dim I As Long, J As Long, K As Long

'Exit if bad input
If R Is Nothing Then Exit Function
'Build temporary space for all areas
ReDim TempArea(1 To R.Areas.Count)
K = 1

For Each Area In R.Areas
'Read in all values from the area
Data = Area
'Return empty string if nothing is there
If IsEmpty(Data) Then GoTo NextArea

'More than one cell?
If Not IsArray(Data) Then
If IsError(Data) Then
'Store error value as appears in cell
TempArea(K) = Area.Text
Else
'Return the value
TempArea(K) = Data
End If
GoTo NextArea
End If

'Build temporary space
ReDim TempCol(1 To UBound(Data))
ReDim TempRow(1 To UBound(Data, 2))

For I = 1 To UBound(Data)
For J = 1 To UBound(Data, 2)
If IsError(Data(I, J)) Then
'Store error values as appears in cells
TempRow(J) = Area(I, J).Text
ElseIf InStr(1, Data(I, J), Separator, vbTextCompare) > 0 Then
'Cells including Separator put in TextQualifier
TempRow(J) = TextQualifier & Data(I, J) & TextQualifier
ElseIf InStr(1, Data(I, J), vbLf, vbBinaryCompare) > 0 Then
'Cells including Linefeed put in TextQualifier
TempRow(J) = TextQualifier & Data(I, J) & TextQualifier
Else
TempRow(J) = Data(I, J)
End If
Next
'Build the row
TempCol(I) = Join(TempRow, Separator)
Next

'Build the area
TempArea(K) = Join(TempCol, vbCrLf)
NextArea:
K = K + 1
Next
'Build CSV-String
RangeToCSV = Join(TempArea, vbCrLf)
End Function

Sub Example_CSVToRange()
Dim fso As Object 'FileSystemObject
Dim T As Object 'TextStream
Dim Separator As String, Contents As String

'Get the separator from your country settings
Separator = Application.International(xlListSeparator)

'Install errorhandler, file actions may fail
On Error GoTo ErrorHandler

'Open a CSV-file
Set fso = CreateObject("Scripting.FileSystemObject")
Set T = fso.OpenTextFile("C:\temp\test.csv")
'Read in the complete file
Contents = T.ReadAll
'Close the CSV
T.Close

'Import into sheet
CSVToRange Contents, Range("A1"), Separator
'Done
Exit Sub

ErrorHandler:
MsgBox Err.Number & ": " & Err.Description
End Sub

Sub CSVToRange(ByVal CSVdata As String, _
Optional ImportCell As Range = Nothing, _
Optional Separator As String = ";", _
Optional EndOfLine As Variant)
'Import CSV-data to a given range or current cell, detect EndOfLine if not given.

Dim Data, I As Long
Dim SaveDisplayAlerts As Boolean

'Store to current cell if no cell is given
If ImportCell Is Nothing Then Set ImportCell = ActiveCell
'If cell is nothing we are in a chart
If ImportCell Is Nothing Then Exit Sub
'No data, nothing to do
If Len(CSVdata) = 0 Then Exit Sub

'Data may exceeds limits of sheet or cells
On Error GoTo ExitPoint

'What kind of EndOfLine did we have?
If IsMissing(EndOfLine) Then
Select Case CInt(InStr(CSVdata, vbCr) > 0) * 2 + CInt(InStr(CSVdata, vbLf) > 0)
Case -3
EndOfLine = vbCrLf 'Windows
Case -2
EndOfLine = vbCr 'Mac
Case -1
EndOfLine = vbLf 'Unix
Case Else
'If it is just one line, it doesn't matter.
EndOfLine = vbCrLf
End Select
End If

'Split lines, create 2D-array, turn data vertical
Data = WorksheetFunction.Transpose(Split(CSVdata, EndOfLine))

'Make sure that we did not exceed the number of rows
I = UBound(Data) - 1
If ImportCell.Row + I > Rows.Count Then
'Calclate max. possible rows
I = Rows.Count - ImportCell.Row
'Inform the user that we cut off some data, but continue our work
On Error Resume Next
Err.Raise 6, "CSVToRange", "CSV > " & ImportCell.Parent.Name
End If

With Range(ImportCell, ImportCell.Offset(I, 0))
'Error messages off, we may overwrite some existing data
SaveDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
'Store the data into the sheet
.Value = Data
'Split the data
.TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:=Separator
'Error messages to it's previous state
Application.DisplayAlerts = SaveDisplayAlerts
End With
ExitPoint:
End Sub

Ähnliche fragen