Change separator when exporting CSV with VBA - excel

Question

How can I change the separator that a CSV file is exported with in VBA without changing regional settings etc?
The macro should be used across multiple computers and different users, I don't want to confuse people with changing global settings on their computers.
Is there any way to use another separator?
This is my current code, but the values are separated with commas, I want semicolons
Sub ExportToCSV()
'Variables--------------------------------------------------------------
Dim CSVFileName As String
Dim sheet As Integer
Dim WsData As Worksheet
Set WsData = Worksheets("Database")
'-----------------------------------------------------------------------
WsData.Range(WsData.Cells(7, 9), WsData.Cells(7, 2).End(xlDown)).Copy
Application.DisplayAlerts = False 'avoid "save prompt window"
' Disable screen updating to improve performance
Application.ScreenUpdating = False
Workbooks.Add
ActiveSheet.Paste
' Convert the first row to lowercase
For Each cell In Range("A1:H1")
cell.Value = LCase(cell.Value)
Next cell
CSVFileName = ThisWorkbook.Path & "\" & "Database_" & VBA.Format(VBA.Now, "dd-mm-yy") & ".csv"
ActiveSheet.SaveAs Filename:=CSVFileName, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
' Enable screen updating again
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Note: there could be commas inside the data it is copying.
Any help is greatly appreciated, thank you.

Answer 1

Option Explicit
Sub exportcsv()
Const SHT_NAME = "Database"
Const HDR = 7
Const DELIM = ";"
Dim wb As Workbook, ws As Worksheet, arData
Dim oFSO As Object, oFS As Object
Dim c As Long, i As Long, n As Long, iLastrow As Long
Dim CSVFilename As String, s As String, quote As String
Dim t0 As Single: t0 = Timer
' create text file
Set wb = ThisWorkbook
CSVFilename = wb.Path & "\" & "Database_" & VBA.Format(VBA.Now, "dd-mm-yy") & ".csv"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.CreateTextFile(CSVFilename, True, True) 'overwrite, Unicode
' write out lines
Set ws = wb.Sheets(SHT_NAME)
With ws
iLastrow = .Cells(Rows.count, "B").End(xlUp).Row
' copy to array
arData = .Range("B1:I1").Offset(HDR - 1).Resize(iLastrow - HDR + 1) ' col 2-9
For i = 1 To UBound(arData)
s = ""
For c = 1 To UBound(arData, 2)
' header
If i = 1 Then arData(i, c) = LCase(arData(i, c))
' add quotes if special chr in value
If arData(i, c) Like "*[;""]*" Then
quote = Chr(34) ' "
Else
quote = ""
End If
' change " to ""
arData(i, c) = Replace(arData(i, c), Chr(34), Chr(34) & Chr(34))
If c > 1 Then s = s & DELIM
s = s & quote & arData(i, c) & quote
Next
oFS.writeline s
n = n + 1
Next
End With
oFS.Close
MsgBox n & " lines written to " & CSVFilename, _
vbInformation, Format(Timer - t0, "0.0 secs")
End Sub