[VBA]選択範囲をCSVに保存するマクロ

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

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