Sub CreateCSV() 'Создание файла csv с помощью Print разделитель задается Rz
Dim Rng As Range, DF1 As Byte, File$, Tp1, Rz$, Ki&, Kj%, i&, j%
Set Rng = ActiveSheet.Cells(1).CurrentRegion
'Set Rng = ActiveSheet.UsedRange
'Set Rng = Selection
    File = ThisWorkbook.Path & "\" & Rng.Parent.Name & ".csv"
Tp1 = Rng.Value: Rz = "~": Ki = Rng.Rows.Count: Kj = Rng.Columns.Count
    DF1 = FreeFile: Open File For Output As #DF1
For i = 1 To Ki
    For j = 2 To Kj
        Tp1(i, 1) = Tp1(i, 1) & Rz & Tp1(i, j)
    Next j
    If i = Ki Then Print #DF1, Tp1(i, 1); Else Print #DF1, Tp1(i, 1)
Next i: Close
End Sub

Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, Optional ByVal SourceCharset$) As String
 If Trim(txt$) = "" Then
  ChangeTextCharset = ""
 Else
  On Error Resume Next: Err.Clear
    'SourceCharset$ = "Windows-1251"
    'DestCharset$ = "utf-8"
  With CreateObject("ADODB.Stream")
   .Type = 2
   .Mode = 3
   If Len(SourceCharset$) Then .Charset = SourceCharset$    'Ischodnaja kodirovka
   .Open
   .WriteText txt$
   .Position = 0
   .Charset = DestCharset$                                  'Naznachenie novoji kodirovki
   ChangeTextCharset = .ReadText
   .Close
  End With
 End If
End Function

Sub CreateCSV() 'Save data as CSV with "~" delimiter
Dim Rng As Range, DF1 As Byte, File$, Tp1, Rz$, Ki&, Kj%, i&, j%
Set Rng = ActiveSheet.Cells(1).CurrentRegion
    File = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Rng.Parent.Name & ".csv"
Tp1 = Rng.Value: Rz = "~": Ki = Rng.Rows.Count: Kj = Rng.Columns.Count
    DF1 = FreeFile: Open File For Output As #DF1
For i = 1 To Ki
    For j = 2 To Kj
        Tp1(i, 1) = ChangeTextCharset(Tp1(i, 1), "utf-8","Windows-1251") & Rz & Tp1(i, j)
    Next j
    If i = Ki Then Print #DF1, ChangeTextCharset(Tp1(i, 1), "utf-8","Windows-1251"); Else Print #DF1, ChangeTextCharset(Tp1(i, 1), "utf-8","Windows-1251")
Next i: Close
End Sub

'-----------------------------------------
Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, Optional ByVal SourceCharset$) As String If Trim(txt$) = "" Then
  ChangeTextCharset = ""
 Else
  On Error Resume Next: Err.Clear
    'SourceCharset$ = "Windows-1251"
    'DestCharset$ = "utf-8"
  With CreateObject("ADODB.Stream")
   .Type = 2
   .Mode = 3
   If Len(SourceCharset$) Then .Charset = SourceCharset$    'Ischodnaja kodirovka
   .Open
   .WriteText txt$
   .Position = 0
   .Charset = DestCharset$                                  'Naznachenie novoji kodirovki
   ChangeTextCharset = .ReadText
   .Close
  End With
 End If
End Function

Sub CreateCSV() 'Создание файла csv с помощью Print разделитель задается Rz
Dim Rng As Range, DF1 As Byte, File$, Tp1, Rz$, Ki&, Kj%, i&, j%, Txt$
Set Rng = ActiveSheet.Cells(1).CurrentRegion
    File = ThisWorkbook.Path & "\" & Rng.Parent.Name & ".csv"
Tp1 = Rng.Value: Rz = "~": Ki = Rng.Rows.Count: Kj = Rng.Columns.Count
    DF1 = FreeFile: Open File For Output As #DF1
For i = 1 To Ki
    For j = 2 To Kj
        Tp1(i, 1) = Tp1(i, 1) & Rz & Tp1(i, j)
    Next j
Txt = ChangeTextCharset(Tp1(i, 1), "Windows-1251", "utf-8")
    If i = Ki Then Print #DF1, Txt; Else Print #DF1, Txt
Next i: Close
End Sub
Function ChangeTextCharset(ByVal Txt$, ByVal DestCharset$, Optional ByVal SourceCharset$) As String
    On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2: .Mode = 3
        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
        .Open
        .WriteText Txt$
        .Position = 0
        .Charset = DestCharset$    ' назначаем новую кодировку
        ChangeTextCharset = .ReadText
        .Close
    End With
End Function

Sub CreateCSV()
    Const sDEL As String = "~"  
    Dim rngData As Range, vData As Variant
    Dim strMyFile As String
    Dim i As Long, j As Long
    Dim lRows As Long, lCols As Long
    
    Set rngData = ActiveSheet.Range("A1").CurrentRegion
    vData = rngData.Value
    lRows = UBound(vData, 1)
    lCols = UBound(vData, 2)
    
    strMyFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & ActiveSheet.Name & ".csv"
    
    Open strMyFile For Output As #1
        For i = 1 To lRows
            For j = 1 To lCols
                vData(i, 1) = vData(i, 1) & sDEL & vData(i, j)
            Next j
            Print #1, vData(i, 1)
        Next i
    Close #1
End Sub