Excel Speichern als .CSV mit Semikolon zeichen
Wenn man Excel in vba Makro als CSV Datei speichert, dann wird die Liste mit Komma ausgegeben.
Hierzu muss man zur Korrektur bei SaveAs den Paramater Local auf True setzen und bei anschliessenden Close SaveChanges auf false
If bSaveas_Csv Then objExcel.SaveAs sFilename_full, XlFileFormat.xlCSV, Local:=True objExcel.Close SaveChanges:=False MsgBox "Die Datei wurde als .csv gespeichert.." & vbCrLf & sFilename_full, vbOKOnly Else objExcel.Close SaveChanges:=True, Filename:=sFilename_full End If '--</ speichern >--
|
Für die Verwendung beim Öffnen einer Excel Datei muss man die lokalen Einstellungen anpassen
Hierzu unter den älteren Systemen auf Systemsteuerung
Dann Region und Sprache
Dann Formate->Weitere Einstellungen->Listentrennzeichen
Option Compare Database Option Explicit On
'=========================================< FUNKTIONEN >=========================================
Public Sub fp_EXCEL_Ausgabe(ByVal parQueryname As String, Optional ByVal sFilename As String, Optional ByVal sSheetname As String, Optional ByVal Opt_As_Csv As Boolean) '--------------------< fp_EXCEL_Ausgabe() >-------------------- '----< Excel bearbeiten >---- '*qryShow_Project_Responses_InForm
'< create > 'Dim appExcel As Excel.Application Dim objExcel As Excel.Workbook Set objExcel = Workbooks.Add '</ create >
'< Filename festlegen > Dim sLabel As String If Not IsMissing(sFilename) Then sLabel = sFilename Else sLabel = "Liste_" & Format(Of Date, "yyyy-MM-dd") End If
'</ Filename festlegen >
Dim objSheet As Excel.Worksheet Set objSheet = objExcel.Worksheets(1) If Not IsMissing(sSheetname) Then objSheet.Name = sSheetname End If
Dim sSQL As String sSQL = CurrentDb.QueryDefs(parQueryname).SQL
Dim qry As QueryDef Set qry = CurrentDb.QueryDefs(parQueryname) Dim par As Parameter For Each par In qry.Parameters If par.Name Like "*frm_Orders_Versand*ctlListe*" Then par.Value = Forms("frm_Orders_Versand")!ctlListe ElseIf par.Name Like "*ctlDtErfassung*" Then par.Value = Forms("frm_Projects_Responses")!ctlDtErfassung sLabel = sLabel & "_KW" & Format(par.Value, "ww") ElseIf par.Name Like "IDProject" Then
End If Next Dim rec As Recordset On Error Resume Next Set rec = qry.OpenRecordset(dbOpenSnapshot) If Err.Number <> 0 Then MsgBox Err.Description Set rec = Nothing Exit Sub End If If Not rec.EOF Then '--------< hat Records >-------- Dim nRecordcounts As Long rec.MoveLast nRecordcounts = rec.RecordCount rec.MoveFirst
'< init > Dim iField As Long Dim iFieldmax As Long iFieldmax = rec.Fields.Count
Dim iRow As Long iRow = 1 '</ init >
'--< Header ausgeben >-- For iField = 0 To iFieldmax - 1 objSheet.Cells(1, iField + 1).Value = rec.Fields(iField).Name Next '--</ Header ausgeben >-- '----< @Loop: Zeilen >---- Do Until rec.EOF '----< ZEile >---- iRow = iRow + 1 DoEvents
DoCmd.Echo True, "row " & iRow & " von " & nRecordcounts '--< rec.Zellen ausgeben >-- For iField = 0 To iFieldmax - 1 objSheet.Cells(iRow, iField + 1).Value = rec.Fields(iField).Value Next '--</ rec.Zellen ausgeben >--
rec.MoveNext '----</ ZEile >---- Loop '----</ @Loop: Zeilen >---- '--------</ hat Records >-------- End If
'< Saveformat ermitteln > Dim bSaveas_Csv As Boolean bSaveas_Csv = False
If IsMissing(Opt_As_Csv) = False Then If Opt_As_Csv = True Then bSaveas_Csv = True End If End If '</ Saveformat ermitteln >
'--< speichern >-- Dim sPath As String sPath = CurrentProject.Path sPath = sPath & "\_export"
'< Ordner pruefen und erstellen > Dim fs As New FileSystemObject If fs.FolderExists(sPath) = False Then fs.CreateFolder sPath End If '< Ordner pruefen und erstellen >
'< Ausgabe_Pfad und Name festlegen > Dim sFilename_full As String If bSaveas_Csv Then sFilename_full = sPath & "\Versandlisten_DHL_csv\" & sLabel Else sFilename_full = sPath & "\" & sLabel End If '</ Ausgabe_Pfad und Name festlegen >
On Error Resume Next
If bSaveas_Csv Then
objExcel.SaveAs sFilename_full, XlFileFormat.xlCSV, Local:=True objExcel.Close SaveChanges:=False MsgBox "Die Datei wurde als .csv gespeichert.." & vbCrLf & sFilename_full, vbOKOnly Else objExcel.Close SaveChanges:=True, Filename:=sFilename_full End If '--</ speichern >--
'</ Abschluss > '*unbedingt schliessen... Set objExcel = Nothing '</ Abschluss >
'< oeffnen > If bSaveas_Csv Then Shell "explorer.exe " & sPath & "\Versandlisten_DHL_csv\" Else Shell "Excel.exe " & sFilename_full & ".xlsx" End If '</ oeffnen >
'----</ Excel bearbeiten >----
'--------------------</ fp_EXCEL_Ausgabe() >-------------------- End Sub
Public Sub fp_EXCEL_Ausgabe_Barcode(ByVal parQueryname As String, Optional ByVal sFilename As String, Optional ByVal sSheetname As String) '--------------------< fp_EXCEL_Ausgabe() >-------------------- '----< Excel bearbeiten >---- '*qryShow_Project_Responses_InForm
'< create > 'Dim appExcel As Excel.Application Dim objExcel As Excel.Workbook Set objExcel = Workbooks.Add '</ create >
'< Filename festlegen > Dim sLabel As String If Not IsMissing(sFilename) Then sLabel = sFilename Else sLabel = "Liste_" & Format(Of Date, "yyyy-MM-dd") End If
'</ Filename festlegen >
Dim objSheet As Excel.Worksheet Set objSheet = objExcel.Worksheets(1) If Not IsMissing(sSheetname) Then objSheet.Name = sSheetname End If
Dim sSQL As String sSQL = CurrentDb.QueryDefs(parQueryname).SQL
Dim qry As QueryDef Set qry = CurrentDb.QueryDefs(parQueryname) Dim par As Parameter For Each par In qry.Parameters If par.Name Like "*frm_Orders_Versand*ctlListe*" Then par.Value = Forms("frm_Orders_Versand")!ctlListe ElseIf par.Name Like "*ctlDtErfassung*" Then par.Value = Forms("frm_Projects_Responses")!ctlDtErfassung sLabel = sLabel & "_KW" & Format(par.Value, "ww") ElseIf par.Name Like "IDProject" Then
End If Next Dim rec As Recordset On Error Resume Next Set rec = qry.OpenRecordset(dbOpenSnapshot) If Err.Number <> 0 Then MsgBox Err.Description Set rec = Nothing Exit Sub End If If Not rec.EOF Then '--------< hat Records >-------- Dim nRecordcounts As Long rec.MoveLast nRecordcounts = rec.RecordCount rec.MoveFirst
'< init > Dim iField As Long Dim iFieldmax As Long iFieldmax = rec.Fields.Count
Dim iRow As Long iRow = 1 '</ init >
'--< Header ausgeben >-- For iField = 0 To iFieldmax - 1 objSheet.Cells(1, iField + 1).Value = rec.Fields(iField).Name Next '--</ Header ausgeben >-- '----< @Loop: Zeilen >---- Do Until rec.EOF '----< ZEile >---- iRow = iRow + 1 DoEvents
DoCmd.Echo True, "row " & iRow & " von " & nRecordcounts '--< rec.Zellen ausgeben >-- For iField = 0 To iFieldmax - 1 objSheet.Cells(iRow, iField + 1).Value = rec.Fields(iField).Value Next '--</ rec.Zellen ausgeben >-- Dim iPos As Integer iPos = InStr(1, sFilename, "_ORDERS_", vbTextCompare) iPos = iPos + Len("_") sFilename = Mid(sFilename, iPos) & ".csv" Dim sID As Long sID = DLookup("IDImport_Orders_File", "tbl_Orders_Masterfiles", "Filename like '" & sFilename & "'")
Dim sEncode_Text As String sEncode_Text = sID & "_" & objSheet.Cells(iRow, 9).Text
'< barCode > create_Barcode39_via_Clipboard objSheet, objSheet.Cells(iRow, 12), sEncode_Text '</ barCode >
rec.MoveNext '----</ ZEile >---- Loop '----</ @Loop: Zeilen >---- '--------</ hat Records >-------- End If
'--< speichern >-- Dim sPath As String sPath = CurrentProject.Path sPath = sPath & "\_export"
'< Ordner pruefen und erstellen > Dim fs As New FileSystemObject If fs.FolderExists(sPath) = False Then fs.CreateFolder sPath End If '< Ordner pruefen und erstellen >
Dim sFilename_full As String sFilename_full = sPath & "\" & sLabel On Error Resume Next objExcel.Close SaveChanges:=True, Filename:=sFilename_full '--</ speichern >--
'</ Abschluss > '*unbedingt schliessen... Set objExcel = Nothing '</ Abschluss >
'< oeffnen > Shell "Excel.exe " & sFilename_full & ".xlsx" '</ oeffnen >
'----</ Excel bearbeiten >----
'--------------------</ fp_EXCEL_Ausgabe() >-------------------- End Sub '=========================================</ FUNKTIONEN >========================================= |