VBA to save a selected area as CSV

[keranali]

Hello everyone,

Is there a VBA to save a selected number of cells as a CSV file allowing the save as dialog box to open and to allow a file location. When finished saving the CSV file opens.


Thanks
K

 

[james_lankford]

I would run the macro recorder to select the cells, open a new workbook, copy the selected cells to the new workbook and then save the new workbook

then I would adjust the recorded macro to make it more generic

 

[keranali]

Ok Thanks I got this so far how do you allow the save dialog box to open.

     Range("C1:N25").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:= _
    "C:\Users\Keran\Desktop\Data01.csv" _
    , FileFormat:=xlCSV, CreateBackup:=False
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

thanks

 

[Ruddles]

I think I may have the code you're looking for:-

Option Explicit
 
Public Sub ExcelRowsToCSV()
 
  Dim iPtr As Integer
  Dim sFileName As String
  Dim intFH As Integer
  Dim aRange As Range
  Dim iLastColumn As Integer
  Dim oCell As Range
  Dim iRec As Long
 
  Set aRange = Application.InputBox("Select a range:-", , Selection.Address, , , , , Type:=8)
  iLastColumn = aRange.Column + aRange.Columns.Count - 1
  
  iPtr = InStrRev(ActiveWorkbook.FullName, ".")
  sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".csv"
  sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="CSV (Comma delimited) (*.csv), *.csv")
  If sFileName = "False" Then Exit Sub
    
  Close
  intFH = FreeFile()
  Open sFileName For Output As intFH
  
  iRec = 0
  For Each oCell In aRange
    If oCell.Column = iLastColumn Then
      Print #intFH, oCell.Value
      iRec = iRec + 1
    Else
      Print #intFH, oCell.Value; ",";
    End If
  Next oCell
   
  Close intFH
  
  MsgBox "Finished: " & CStr(iRec) & " records written to " _
     & sFileName & Space(10), vbOKOnly + vbInformation
 
End Sub

Any good?

 

[keranali]

Hi thanks for the reply whit if the range is fixed C2:N25, I am also getting a runtime error 5

 

[keranali]

I found this code from http://www.rondebruin.nl/saveas.htm

Sub Copy_ActiveSheet_2()
'Working in Excel 2000-2010
    Dim fname As Variant
    Dim NewWb As Workbook
    Dim FileFormatValue As Long

    'Check the Excel version
    If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:="", _
        FileFilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")

        If fname <> False Then
            'Copy the ActiveSheet to new workbook
            ActiveSheet.Copy
            Set NewWb = ActiveWorkbook

            'We use the 2000-2003 format xlWorkbookNormal here to save as xls
            NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
            NewWb.Close False
            Set NewWb = Nothing

        End If
    Else
        'Give the user the choice to save in 2000-2003 format or in one of the
        'new formats. Use the "Save as type" dropdown to make a choice,Default =
        'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
        
        fname = Application.GetSaveAsFilename(InitialFileName:="", FileFilter:= _
        " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
        " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
        " Excel 2000-2003 Workbook (*.xls), *.xls," & _
        " Excel Binary Workbook (*.csv), *.csv", _
        FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

        'Find the correct FileFormat that match the choice in the "Save as type" list
        If fname <> False Then
            Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "csv": FileFormatValue = 6
            Case Else: FileFormatValue = 0
            End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Copy
                Set NewWb = ActiveWorkbook

                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing

            End If
        End If
    End If
End Sub

which allows me to save as different extensions however its not giving me a range, How can I get a range from C2:N25

Thanks
K

 

[Ruddles]

Hi thanks for the reply whit if the range is fixed C2:N25

Replace:-

Set aRange = Application.InputBox("Select a range:-", , Selection.Address, , , , , Type:=8)

with:-

Set aRange = Range("C2:N25")

I am also getting a runtime error 5

Make the change I suggested. If you still get an error, let me know which line it occurs on.

 

[keranali]

Hello Ruddles your code work's prefect thanks very much its doing exactly what I needed it to do.

Thanks again
K

 

[keranali]

OK one small problem I believe when I try to over write the existing file in the save dialog box I am getting a "run-time error 70 Permission Denied"

When I debug

Open sFileName For Output As intFH

is highlighted.

Is there a solution around this?

Thanks
K

 

[Ruddles]

Odd, I just tested it and it overwrites the file okay if you choose an existing file.

Do you have permission to overwrite the file manually?