CSV Export im UTF 8 Format
15.08.2019 16:52:07
ferris76
ich hoffe Ihr könnt mir weiterhelfen. Für eine Dateneingabe in Excel habe ich mir verschiedene Makros im Internet zusammengesucht, die für sich jeweils alleine genommen ihre Aufgabe erfüllen.
Als erstes werden die erfassen Daten per Button und Makro in ein anderes Tabellenblatt geschrieben:
Sub Schaltfläche4_KlickenSieAuf()
Worksheets("CSV").Rows("2:11").Insert shift:=xlDown
Range("A34:AU43").Copy
Worksheets("CSV").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Als zweites lösche ich über ein weiteres Makro die nicht benötigten Leerzeilen:
Sub Leerzeilen_loeschen()
Dim lngSpalte As Long
'** Spalte, die auf Leerzeichen geprüft werden soll
lngSpalte = 1
For A = Worksheets("CSV").Cells(Rows.Count, lngSpalte).End(xlUp).Row To 1 Step -1
If Worksheets("CSV").Cells(A, 1).Value = "" Then
Rows(A).Delete shift:=xlUp
End If
Next A
End Sub
Und als drittes sollen dann die Daten als CSV im UTF8 Format gespeichert werden. Das erledigt folgendes Makro:
Sub SaveUTF8File()
Dim fname As Variant
fname = Application.GetSaveAsFilename("UTF8.csv", "CSV-Dateien,*.csv,Alle Dateien,*.*")
If fname = False Then Exit Sub
SaveAsUTF8CSV (fname)
End Sub
Sub SaveAsUTF8CSV(fname As String)
Dim hfile As Integer ' Filehandle bzw. Dateinummer
Dim i As Long ' Zähler über alle Zeilen
Dim j As Integer ' Zähler über alle Spalten
Dim OneLine As String ' Eine Zeile als String
Dim maxcol As Integer ' max. Anzahl an Spalten
hfile = FreeFile
maxcol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
Open fname For Output As #hfile
Print #hfile, Chr(&HEF); Chr(&HBB); Chr(&HBF);
For i = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
OneLine = ""
For j = 1 To maxcol - 1
OneLine = OneLine & Cells(i, j).Text & ","
Next j
OneLine = OneLine & Cells(i, j).Text & vbCrLf
Print #hfile, GetUTF8String(OneLine);
Next i
Close #hfile
End Sub
'
' frei nach http://www.vovisoft.com/unicode/UniFunctions.htm#ToUTF8
'
Private Function GetUTF8String(s As String) As String
Dim i As Integer ' Zähler über die einzelnen Zeichen des utf16-Strings
Dim utf16 As Long, uc(2) As Byte
GetUTF8String = ""
For i = 1 To Len(s)
utf16 = AscW(Mid(s, i, 1))
If utf16
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
Ich habe jetzt Daten eingegeben und jeweils immer abgespeichert. Dabei ist nach dem Löschen der überflüssigen Leerzeilen ein Tabellenblatt mit 140 Zeilen übriggeblieben. Wenn diese jetzt versuche als CSV abzuspeichern, bricht die Datei entweder bei Zeile 44 ab oder es wird ein Überlauf (Fehler 6) produziert, die Datei enthält aber immer noch nicht alle Daten und ist knappe 1,7 MB groß. Kann mir jemand weiterhelfen?
Gruß
ferris76
Anzeige