Formatierungsproblem beim Textexport
17.10.2019 16:25:58
jojo
ich habe folgenden Code gefunden um meine Tabelle als txt-Datei zu speichern, allerdings zerhaut es mir meine Prozentformatierung: ich hab in der Tabelle "1,5%" stehen und das wird zu "0,015"... Habt ihr da einen Tipp für mich?
Option Explicit
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Private Const CP_UTF8 As Long = 65001
Private Const FILE_NAME = "C:\Desktop\Test\Ausgabe.txt"
Public Sub UTF8_Main()
Dim strText As String
Dim objRange As Range
Application.ScreenUpdating = False
Sheets("fertig").Select
If Get_Range(objRange) Then
If Build_Output_String(objRange, strText) Then
If Create_UTF8_File(FILE_NAME, strText) Then
MsgBox "Erstellen der Datei erfolgreich beendet.", _
vbInformation, "Information"
End If
End If
End If
Sheets("Bedienung").Select
Application.ScreenUpdating = True
End Sub
Private Function Get_Range(objRange As Range) As Boolean
Dim lngRow As Long, lngColumn As Long
Dim lngFirstRow As Long, lngFirstColumn As Long
Dim lngLastRow As Long, lngLastColumn As Long
Dim objLastUsedCell As Range
On Error GoTo error_handler
Set objLastUsedCell = Cells.SpecialCells(xlCellTypeLastCell)
For lngRow = objLastUsedCell.Row To 1 Step -1
If WorksheetFunction.CountBlank(Rows(lngRow))
Private Function Build_Output_String(objRange As Range, strText As String) As Boolean
Dim lngRow As Long
Dim vntTempArray As Variant
On Error GoTo error_handler
With objRange
For lngRow = 1 To .Rows.Count
vntTempArray = .Rows(lngRow).Value
vntTempArray = WorksheetFunction.Transpose( _
WorksheetFunction.Transpose(vntTempArray))
strText = strText & Join(vntTempArray, vbTab) & vbCrLf
Next
End With
strText = Left$(strText, Len(strText) - 2)
Build_Output_String = True
Exit Function
error_handler:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler in Prozedur ''Build_Output_String''"
End Function
Private Function Create_UTF8_File(strFileName As String, strText As String) As Boolean
Dim intFileNumber As Integer
Dim bytBuffer() As Byte
Dim lngLength As Long, lngPointer As Long, lngSize As Long
On Error GoTo error_handler
lngLength = Len(strText)
lngPointer = StrPtr(strText)
lngSize = WideCharToMultiByte(CP_UTF8, 0&, _
lngPointer, lngLength, 0&, 0&, 0&, 0&)
ReDim bytBuffer(0 To lngSize - 1)
Call WideCharToMultiByte(CP_UTF8, 0&, lngPointer, _
lngLength, VarPtr(bytBuffer(0)), lngSize, 0&, 0&)
If Dir$(strFileName) vbNullString Then Call Kill(strFileName)
Reset
intFileNumber = FreeFile
Open strFileName For Binary Access Write As #intFileNumber
Put #intFileNumber, , bytBuffer
Close #intFileNumber
Create_UTF8_File = True
Exit Function
error_handler:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler in Prozedur ''Create_UTF8_File''"
End Function