CSV ohne Leerzeilen - bekomme es nicht hin ;-)

Sub SaveCSV_a()
Dim a               As Variant
Dim B()             As String
Dim D()             As String
Dim Z               As Long
Dim S               As Byte
Dim R               As Long
Dim C               As Byte
'Speicherpfad eintragen
Const Path          As String = "C:\Test\"
'Dateiname eintragen
Const filename      As String = "VIP_Blacklist_Update2"
'Dateiendung anpassen (.txt, .csv oder andere)
Const Extension     As String = ".csv"
'Trennzeichen anpassen (Semikolon, Komma oder andere)
Const Separator     As String = ","
'Texerkennungszeichen anpassen (kann meist so bleiben)
Const Wrapper       As String = ""
'Zu speichernden Bereich eintragen z.B:
'Worksheet("DeinTabellenblatt").UsedRange
'Worksheet("DeinTabellenblatt").Range("C19:E600")
'a = ActiveSheet.UsedRange
a = ActiveSheet.Range("C19:E600")
If Not IsEmpty(a) Then
Z = UBound(a, 1)
S = UBound(a, 2)
ReDim B(S - 1)
ReDim D(Z - 1)
For R = 1 To Z
For C = 1 To S
If InStr(1, a(R, C), Separator) > 0 Then
'Rows whith cells including the Separator
'put in Wrapper
B(C - 1) = Wrapper & a(R, C) & Wrapper
Else
B(C - 1) = a(R, C)
End If
Next C
D(R - 1) = Join(B(), Separator)
Next R
Open Path & filename & Extension For Output As #1
Print #1, Join(D(), vbCrLf)
Close #1
End If
End Sub