非常に使う機会が多いので、めも

Sub CSVに保存xlsx()
 
 'エクセルファイル名を取得して、CSVのファイル名にします
    Dim fileName As String
    Dim Target As String, pos As Long
    Target = ActiveWorkbook.Name
    pos = InStrRev(Target, ".")
    If pos > 0 Then
        If LCase(Mid(Target, pos + 1)) = "xls" Then
            fileName = Replace(ActiveWorkbook.Name, ".xls", ".csv")
        ElseIf LCase(Mid(Target, pos + 1)) = "xlsx" Then
            fileName = Replace(ActiveWorkbook.Name, ".xlsx", ".csv")
        Else
            MsgBox "エラー"
        End If
    End If

    thisPath = ActiveWorkbook.Path
 
 Dim fromRange
 fromRange = Selection(1).Address
 Dim toRange
 toRange = Selection(Selection.Count).Address
 fileName = "C:\Users\user1\Desktop\" & fileName
 
  On Error Resume Next
 
 
  Dim txt As Object
  Set txt = CreateObject("ADODB.Stream")
 
  'Set data type to save TEXT.
  txt.Type = adTypeText
  'Set char code to UTF-8
  txt.Charset = "UTF-8"
 
  txt.LineSeparator = adCRLF
 
 
  txt.Open
 
 
  'Set range
  Set r = Range(fromRange, toRange)
 
  Dim rowNo As Integer
  Dim colNo As Integer
  Dim colNoMax As Integer
 
  rowNo = Range(fromRange).Row
  colNoMax = Range(toRange).Column
 
 
  For Each r2 In r
 
      colNo = r2.Column
 
      If rowNo <> r2.Row Then
          rowNo = r2.Row
      End If
 
      'Chr(34) is double quotes
      'txt.WriteText Chr(34)
      txt.WriteText r2.Value
      'txt.WriteText Chr(34)
 
      If colNoMax = r2.Column Then
 
          txt.WriteText vbNewLine
      Else
 
          'Chr(44) is comma
          txt.WriteText Chr(44)
 
      End If
 
  Next r2
 
  txt.SaveToFile fileName, 2
  txt.Close
  Set txt = Nothing

End Sub