Соответствующее приложение от системного лотка

Sub ExportRangetoFile()

Dim Rng As Range
Dim WorkRng As Range
Dim xFile As Variant
Dim xFileString As String

On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ActiveSheet.Copy
Application.ActiveSheet.Cells.Clear
WorkRng.Copy Application.ActiveSheet.Range("A1")
Set xFile = CreateObject("Scripting.FileSystemObject")
xFileString = Application.GetSaveAsFilename("", filefilter:="Comma Separated Text (*.CSV), *.CSV")
Application.ActiveWorkbook.SaveAs Filename:=xFileString, FileFormat:=xlCSV, CreateBackup:=False
End Sub