Modify existing SaveAs VBA to add fixed destination file name

[GuyGadois]

I have the following VBA which works but I would like to adjust it to do the following:

1) Hard code where the file is going to be saved. "C:/investment/guy"
2) Name the new xlsx file the Value of the named range 'Allocation_Model_Name' & date 'YYYMMDD'.CVS
3) Open the new file upon creation to review it.

Is this possible?

Cheers,

GG

Option Explicit
 
Public Sub SaveasCSV()
 
  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 = Range("B2:D200")
  iLastColumn = aRange.Column + aRange.Columns.Count - 1
 
  iPtr = InStrRev(ActiveWorkbook.FullName, ".")
  sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".xlsx"
  sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="Excel Workbooks (*.xlsx*),*.xlsx*")
 
  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

 

[rollis13]

Have try:

Option Explicit
Public Sub SaveasCSV()
    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 = Range("B2:D200")
    iLastColumn = aRange.Column + aRange.Columns.Count - 1
    '---- no longer used ----
    'iPtr = InStrRev(ActiveWorkbook.FullName, ".")
    'sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".xlsx"
    'sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="Excel Workbooks (*.xlsx*),*.xlsx*")
    'If sFileName = "False" Then Exit Sub
    'Close
    '------------------------
    'hardcode path and file name
    sFileName = "C:\investment\guy\" & Range("Allocation_Model_Name").Value & Format(Date, "YYMMDD") & ".CVS" '<- added
    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
    'open file to review it
    Call Shell("C:\Windows\Notepad.exe " & sFileName, vbNormalFocus) '<- added
End Sub

 

[GuyGadois]

Have try:

Option Explicit
Public Sub SaveasCSV()
    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 = Range("B2:D200")
    iLastColumn = aRange.Column + aRange.Columns.Count - 1
    '---- no longer used ----
    'iPtr = InStrRev(ActiveWorkbook.FullName, ".")
    'sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".xlsx"
    'sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="Excel Workbooks (*.xlsx*),*.xlsx*")
    'If sFileName = "False" Then Exit Sub
    'Close
    '------------------------
    'hardcode path and file name
    sFileName = "C:\investment\guy\" & Range("Allocation_Model_Name").Value & Format(Date, "YYMMDD") & ".CVS" '<- added
    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
    'open file to review it
    Call Shell("C:\Windows\Notepad.exe " & sFileName, vbNormalFocus) '<- added
End Sub

@rollis13 , thanks for your reply. The code works pretty good but there are a few issues I was hoping you could help with

1. It is not saving in the directory I was hoping to hard code as: C:\investment\guy\ How do you change it to only save in this directory only?
2. When copying over the info to the new worksheet it is copying over B2:D200 but I would like it to copy only the rows that have value. In this instance, the data today only goes from B2:D25 but every day it changes. Is there a way of just copying the cells with a value?
3. Can it open the newly created workbook in excel instead of Notepad?

Manby thanks,

GG

 

[rollis13]

1. Here is where it's saving sFileName = "C:\investment\guy\" & Range... so what do you mean with not saving in the directory it's the only directory available, can't go anywhere else.
2. This not an issue, you stated that the range was to be Set aRange = Range("B2:D200"). What sort of data do you have in your cells ? I think you will need a iLastRow for that.
3. No problem with Excel but since it's only a text file Notepad was all it needed.
Have another try with these changes:

Option Explicit
Public Sub SaveAsCSV()
    Dim sFileName As String
    Dim intFH  As Integer
    Dim aRange As Range
    Dim iLastColumn As Integer
    Dim iLastRow As Long                          '<- added
    Dim oCell  As Range
    Dim iRec   As Long
    Set aRange = Range("B2:D200")
    iLastColumn = aRange.Column + aRange.Columns.Count - 1
    iLastRow = aRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row '<- added
    Set aRange = Range("B2:D" & iLastRow)         '<- added
    'hardcode path and file name
    sFileName = "C:\investment\guy\" & Range("Allocation_Model_Name").Value & Format(Date, "YYMMDD") & ".cvs"
    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
    'open file to review it
    'Call Shell("C:\Windows\Notepad.exe " & sFileName, vbNormalFocus)
    Workbooks.Open sFileName                      '<- changed
End Sub

 

[GuyGadois]

1. Here is where it's saving sFileName = "C:\investment\guy\" & Range... so what do you mean with not saving in the directory it's the only directory available, can't go anywhere else.
2. This not an issue, you stated that the range was to be Set aRange = Range("B2:D200"). What sort of data do you have in your cells ? I think you will need a iLastRow for that.
3. No problem with Excel but since it's only a text file Notepad was all it needed.
Have another try with these changes:

Option Explicit
Public Sub SaveAsCSV()
    Dim sFileName As String
    Dim intFH  As Integer
    Dim aRange As Range
    Dim iLastColumn As Integer
    Dim iLastRow As Long                          '<- added
    Dim oCell  As Range
    Dim iRec   As Long
    Set aRange = Range("B2:D200")
    iLastColumn = aRange.Column + aRange.Columns.Count - 1
    iLastRow = aRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row '<- added
    Set aRange = Range("B2:D" & iLastRow)         '<- added
    'hardcode path and file name
    sFileName = "C:\investment\guy\" & Range("Allocation_Model_Name").Value & Format(Date, "YYMMDD") & ".cvs"
    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
    'open file to review it
    'Call Shell("C:\Windows\Notepad.exe " & sFileName, vbNormalFocus)
    Workbooks.Open sFileName                      '<- changed
End Sub

Thank you. That was my fault about the save location. I forgot the last "\" which messed it up. The iLastRow seems to work great. As far as the format of the data, I do need to make sure the format is adjusted after it is pasted into the new sheet. Column A has to be in MM/DD/YYYY and column C needs to be in number format 000.0000 (4 decimal places). The tricky thing is the uploader I am using doesn't like it when I format the entire columns unless I change the format of the headers back to General. How do I change the formatting of the data on the new workbook?

Thank you so much! ... GG

 

[rollis13]

Seems to be a very different question, I suggest you start a new thread with appropriated title.