Sub CreateCSV()
Dim il As Long, iu As Long, jl As Long, ju As Long, i As Long, j As Long
Dim DataArray As Variant
Dim strLine As String, strCell As String
Dim intOutFile As Integer
Dim Filename As String
Filename = "d:\daten\scalelabel.csv"
With Worksheets("03 Single Line")
DataArray = Range("A3", LastCell(ActiveSheet))
il = LBound(DataArray, 1)
iu = UBound(DataArray, 1)
jl = LBound(DataArray, 2)
ju = UBound(DataArray, 2)
intOutFile = FreeFile
Open Filename For Append As intOutFile
For i = il To iu
strLine = DataArray(i, 1)
For j = jl + 1 To ju
strCell = Trim(DataArray(i, j))
If InStr(strCell, ",") > 0 Then strCell = """" & strCell & """"
strLine = strLine & ";" & strCell
Next j
Print #intOutFile, strLine
Next i
Close intOutFile
End With
End Sub