CSV-File - Makro macht aus Wert nicht 0.00
11.01.2016 11:48:53
Beat
Ich hänge hier an einer Problemstellung fest, für die ihr wohl das Wort Problem nicht mal annähernd in Betracht ziehen würdet ;-).
Ausgangslage:
Ich habe eine Excel-Datei, in welcher weltweit (CH, DE, USA, Asien usw.) Daten erfasst und danach in ein Tool mittels CSV-File geladen werden sollen. Die Daten werden in der 'Upload-Tabelle' (Siehe Beilage https://www.herber.de/bbs/user/102717.xlsm ) zuerst aufgelistet in den Spalten A-O, danach gefiltert nach den Kriterien der Spalten R-S in den Spalten U-AG für den Upload aufgelistet. Das Makro erstellt nun eine Kopie dieser Tabelle, fixiert die Werte und löscht die Spalten A-T raus, bevor der Rest als CSV-File abgespeichert wird.
Problem:
Das Problem besteht darin, dass ich die Programmierung nicht hinkriege, dass die Werte unabhängig der Grundeinstellungen der jeweiligen Länder in Office mit Punkt und 2 Dezimalstellen im CSV-File stehen. In DE und Asien z.B. gilt das Komma als Dezimaltrenner.
Im Makro versuche ich dies wie folgt zu lösen:
If CurrCell.Column = 12 Then
CurrTextStr = CurrTextStr & Format(CurrCell.Value, "#####################0.00") & ListSep
Das haut aber leider in Deutschland und Asien nicht hin: da habe ich nach wie vor ein Komma im Uploadfile. Wenn die Länder ihre XLS-Grundeinstellungen ändern, dann geht's - dann habe sie aber bei allen anderen Files Probleme, welche sie im 'Landesformat' bearbeiten/laden müssen.
Ich denke, ich kann mit meiner Einstellung die Grundeinstellungen nicht ausbooten.
Hat evtl. jemand eine Idee? Jetzt schon herzlichen Dank an alle, die Zeit aufwenden, um mir zu helfen !!!
Hier nochmals der Link zur Anlage: https://www.herber.de/bbs/user/102717.xlsm
Hier das gesamte Makro:
Sub CSVACTIC()
' CSVACTIC Makro
' Filter ausführen, CSV-File erstellen für Tabelle "Upload_ACT_&IC"
' leeren Zielbereich Filter
Sheets("Upload_ACT_&IC").Select
Range("U1:AG1").Select
Selection.Copy
Range("AI1").Select
ActiveSheet.Paste
Columns("AI:AU").Select
Application.CutCopyMode = False
Selection.Cut
Columns("U:AG").Select
ActiveSheet.Paste
Range("N1").Select
' Filter ausführen
Range("A:M").AdvancedFilter Action:=xlFilterCopy, CriteriaRange _
:=Range("R1:S2"), CopyToRange:=Range("U1:AG1"), Unique:=False
' CSV-File erstellen
Dim wks As Worksheet
Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant, FPath As String
Dim FF As Integer
'Vorgabe-Verzeichnis der CSV-Datei
FPath = ActiveWorkbook.Path 'Verzeichnis der aktiven Arbeitsmappe
FPath = "C:\Users\" & VBA.Environ("Username") & "\Desktop" '"C:\Users\" ggf. anpassen
FPath = FPath & Application.PathSeparator
'Vorgabe-Dateiname aus Werten im Blatt Settings bilden
With Worksheets("Upload_ACT_&IC")
.Range("A7").Calculate
FName = "Upload_ACT_&IC_" & .Range("Q10").Text & "_PL_" & .Range("Q7").Text & .Range(" _
Q5").Text & "_" & Format(.Range("Q13"), "yyyymmdd") & "-" & Format(.Range("Q13"), "hhmm") & ".csv"
End With
'Auswahldialog für Dateinahme anzeigen
FName = Application.GetSaveAsFilename(FPath & FName, "CSV File (*.csv), *.csv")
If FName = False Then Exit Sub
Set wks = ActiveWorkbook.Sheets("Upload_ACT_&IC") 'Name ggf. anpassen
'Blatt in temproräres Blatt kopieren
wks.Copy after:=wks
Set wks = ActiveSheet
wks.Name = "Upload_ACT_&IC_c" & Format(Now, "YYYYMMDD hhmmss")
With wks
'Formeln durch Werte ersetzen
With .UsedRange
.Copy
.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End With
'Spalten löschen
.Range("A:T").EntireColumn.Delete shift:=xlShiftToLeft
End With
Range("A1").Select
ListSep = Application.International(xlListSeparator)
If Selection.Cells.Count > 1 Then
Set SrcRg = Selection
Else
Set SrcRg = ActiveSheet.UsedRange
End If
FF = FreeFile
Open FName For Output As #FF
For Each CurrRow In SrcRg.Rows
CurrTextStr = "" ' ìî
For Each CurrCell In CurrRow.Cells
' Erstellen Zeilen mit ListSeparator (;) und Definition Spalte mit Value (hier =12), _
Formatierung mit Zahl 2 Kommastellen
If CurrCell.Column = 12 Then
CurrTextStr = CurrTextStr & Format(CurrCell.Value, "#####################0.00") _
& ListSep
Else
CurrTextStr = CurrTextStr & CurrCell.Value & ListSep
End If
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #FF, CurrTextStr
Next
Close #FF
'temporäre Blattkopie wieder löschen
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
' zurück an den Ursprungsort
Sheets("Upload-Cockpit").Select
Range("E25").Select
End Sub