Help with VBA Script code!

[Jemmick]

i have a excel file that grabs data from an odbc drive then compiles the data into a csv file. I want to update the script below to save the file to the users desktop (its fine if i have to modify the username code) with no prompts. I stole this script from someone else's example and can't figure out how to modify it to save to the desktop versus "save as". Please help so I can wrap up this project!


===================================
Sub ExportRangetoFile()
' -------------------------------------------------------------------------------------------------------------------
'
' General function: exports strings contained in a range (1 column wide, varying height) into a text file
'
' -------------------------------------------------------------------------------------------------------------------
Const ForAppending = 8
Const rStartCell = "macroSwitch_OutputTextBelow"
Const strFileNamePrefix = "Valor Teamworx Export "
Dim fs, f
Dim saveFile As String
Dim WorkRng As Range
Dim iHeightOfDataRange


On Error Resume Next


' figure out how many rows to select and export:
' start at range "macroSwitch_OutputTextBelow"
' look down to last filled in row to count number of rows with actual check data
' then use that height as height for range to be exported
iHeightOfDataRange = Range(rStartCell).End(xlDown).Row - Range(rStartCell).Row


Set WorkRng = Application.Selection
Set WorkRng = Range(rStartCell).Offset(1, 0).Resize(iHeightOfDataRange, 1)
Application.ScreenUpdating = False
Application.DisplayAlerts = False


' create file to export to
Set fs = CreateObject("Scripting.FileSystemObject")
saveFile = Application.GetSaveAsFilename(InitialFileName:=strFileNamePrefix & Format(Now(), "yyyy-mm-dd"), _
filefilter:="Comma Separated Text (*.CSV), *.CSV")
Set f = fs.createTextFile(saveFile, ForAppending, TristateFalse)


' and write export range line by line
For Each Row In WorkRng.Rows
f.writeline Row
Next Row
f.Close


Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True




End Sub
==========================================

 

[Norie]

Do you mean you want to alter this so instead of the user selecting the filename and path to save it's hard coded to save to their desktop?

saveFile = Application.GetSaveAsFilename(InitialFileName:=strFileNamePrefix & Format(Now(), "yyyy-mm-dd"), _
filefilter:="Comma Separated Text (*.CSV), *.CSV")

If so, what filename would you want to use?

 

[Jemmick]

Do you mean you want to alter this so instead of the user selecting the filename and path to save it's hard coded to save to their desktop?

saveFile = Application.GetSaveAsFilename(InitialFileName:=strFileNamePrefix & Format(Now(), "yyyy-mm-dd"), _
filefilter:="Comma Separated Text (*.CSV), *.CSV")

If so, what filename would you want to use?

Yes I would want it hardcoded to save as TeamWorxUpload.csv

 

[Norie]

Try this.

Sub ExportRangetoFile()
' -------------------------------------------------------------------------------------------------------------------
'
' General function: exports strings contained in a range (1 column wide, varying height) into a text file
'
' -------------------------------------------------------------------------------------------------------------------
Const ForAppending = 8
Const TristateFalse = 0
Const rStartCell = "macroSwitch_OutputTextBelow"
Const strFileNamePrefix = "Valor Teamworx Export "
Dim fs, f
Dim saveFile As String
Dim WorkRng As Range
Dim iHeightOfDataRange
Dim strDeskTopPath As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next

    ' get path to user's desktop
    strDeskTopPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
    ' figure out how many rows to select and export:
    ' start at range "macroSwitch_OutputTextBelow"
    ' look down to last filled in row to count number of rows with actual check data
    ' then use that height as height for range to be exported
    iHeightOfDataRange = Range(rStartCell).End(xlDown).Row - Range(rStartCell).Row
    
    
    Set WorkRng = Application.Selection
    Set WorkRng = Range(rStartCell).Offset(1, 0).Resize(iHeightOfDataRange, 1)

    ' create file to export to
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    saveFile = strDeskTopPath & "\TeamWorxUpload.csv"
    
    Set f = fs.createTextFile(saveFile, ForAppending, TristateFalse)
        
    ' and write export range line by line
    For Each Row In WorkRng.Rows
        f.writeline Row
    Next Row
    
    f.Close
        
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
End Sub

 

[Jemmick]

Try this.

Sub ExportRangetoFile()
' -------------------------------------------------------------------------------------------------------------------
'
' General function: exports strings contained in a range (1 column wide, varying height) into a text file
'
' -------------------------------------------------------------------------------------------------------------------
Const ForAppending = 8
Const TristateFalse = 0
Const rStartCell = "macroSwitch_OutputTextBelow"
Const strFileNamePrefix = "Valor Teamworx Export "
Dim fs, f
Dim saveFile As String
Dim WorkRng As Range
Dim iHeightOfDataRange
Dim strDeskTopPath As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next

    ' get path to user's desktop
    strDeskTopPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
    ' figure out how many rows to select and export:
    ' start at range "macroSwitch_OutputTextBelow"
    ' look down to last filled in row to count number of rows with actual check data
    ' then use that height as height for range to be exported
    iHeightOfDataRange = Range(rStartCell).End(xlDown).Row - Range(rStartCell).Row
    
    
    Set WorkRng = Application.Selection
    Set WorkRng = Range(rStartCell).Offset(1, 0).Resize(iHeightOfDataRange, 1)

    ' create file to export to
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    saveFile = strDeskTopPath & "\TeamWorxUpload.csv"
    
    Set f = fs.createTextFile(saveFile, ForAppending, TristateFalse)
        
    ' and write export range line by line
    For Each Row In WorkRng.Rows
        f.writeline Row
    Next Row
    
    f.Close
        
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
End Sub

That got it you are awesome!

 

[Jemmick]

Try this.

Sub ExportRangetoFile()
' -------------------------------------------------------------------------------------------------------------------
'
' General function: exports strings contained in a range (1 column wide, varying height) into a text file
'
' -------------------------------------------------------------------------------------------------------------------
Const ForAppending = 8
Const TristateFalse = 0
Const rStartCell = "macroSwitch_OutputTextBelow"
Const strFileNamePrefix = "Valor Teamworx Export "
Dim fs, f
Dim saveFile As String
Dim WorkRng As Range
Dim iHeightOfDataRange
Dim strDeskTopPath As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next

    ' get path to user's desktop
    strDeskTopPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop")
    
    ' figure out how many rows to select and export:
    ' start at range "macroSwitch_OutputTextBelow"
    ' look down to last filled in row to count number of rows with actual check data
    ' then use that height as height for range to be exported
    iHeightOfDataRange = Range(rStartCell).End(xlDown).Row - Range(rStartCell).Row
    
    
    Set WorkRng = Application.Selection
    Set WorkRng = Range(rStartCell).Offset(1, 0).Resize(iHeightOfDataRange, 1)

    ' create file to export to
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    saveFile = strDeskTopPath & "\TeamWorxUpload.csv"
    
    Set f = fs.createTextFile(saveFile, ForAppending, TristateFalse)
        
    ' and write export range line by line
    For Each Row In WorkRng.Rows
        f.writeline Row
    Next Row
    
    f.Close
        
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        
End Sub

WHAT IF I WANT TO NAME THE FILE NAME "TeamworkUpload010131.csv" where the 010131 is equal to yesterdays date

 

[Norie]

Try this.

saveFile = strDeskTopPath & "\TeamWorxUpload" & Format(Date()-1, "ddmmyyyy") & ".csv"

Change 'ddmmyyyy' to get the date formatting you want.