Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User
Excel ;

Excel Speichern als .CSV mit Semikolon zeichen

04.10.2019 (👁709)

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 >=========================================