非常に使う機会が多いので、めも
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