How to add a defult in VB script I found this great script I found where it save

Question

How to add a defult in VB script I found this great script I found where it saves each worksheet to a separate CVS file and in a dir. Now I have 3 questions How can I A 1) Set the default delimiter to always be ',' (comma) and never prompt me 2) set the default dir to D:entitlement report Template and never prompt me 3) save the file as the worksheet name (which it already does) PLUS add the current time/date stamp? example ( filename-10-09-2014-10:00amEST) here is the code --------------------------------------------------------------------------- ' ---------------------- Directory Choosing Helper Functions ----------------------- ' Excel and VBA do not provide any convenient directory chooser or file chooser ' dialogs, but these functions will provide a reference to a system DLL ' with the necessary capabilities Private Type BROWSEINFO ' used by the function GetFolderName hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetFolderName(Msg As String) As String ' returns the name of the folder selected by the user Dim bInfo As BROWSEINFO, path As String, r As Long Dim X As Long, pos As Integer bInfo.pidlRoot = 0& ' Root folder = Desktop If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." ' the dialog title Else bInfo.lpszTitle = Msg ' the dialog title End If bInfo.ulFlags = &H1 ' Type of directory to return X = SHBrowseForFolder(bInfo) ' display the dialog ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetFolderName = Left(path, pos - 1) Else GetFolderName = "" End If End Function '---------------------- END Directory Chooser Helper Functions ---------------------- Public Sub DoTheExport() Dim FName As Variant Dim Sep As String Dim wsSheet As Worksheet Dim nFileNum As Integer Dim csvPath As String Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _ "Export To Text File") 'csvPath = InputBox("Enter the full path to export CSV files to: ") csvPath = GetFolderName("Choose the folder to export CSV files to:") If csvPath = "" Then MsgBox ("You didn't choose an export directory. Nothing will be exported.") Exit Sub End If For Each wsSheet In Worksheets wsSheet.Activate nFileNum = FreeFile Open csvPath & "" & _ wsSheet.Name & ".csv" For Output As #nFileNum ExportToTextFile CStr(nFileNum), Sep, False Close nFileNum Next wsSheet End Sub Public Sub ExportToTextFile(nFileNum As Integer, _ Sep As String, SelectionOnly As Boolean) Dim WholeLine As String Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Application.ScreenUpdating = False On Error GoTo EndMacro: If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Coolumn End With End If For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartColl To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = "" Else CellValue = Cells(RowNdx, ColNdx).Value End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #nFileNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreeenUpdating = Trrue End Sub

Explanation / Answer

Hi,

you can't use in file name the colon <:> symbol (h:mm)

try this...

Sub a_001()
'Oct 08, 2014
Const sep As String = ","
Dim fpath As String
fpath = "D:entitlement report" '<< folder path, change
Dim ws As Worksheet
Dim r As Long, c As Long, i As Long, j As Long

Dim myFile As String, sNow As String

For Each ws In ActiveWorkbook.Worksheets
r = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
sNow = Format(Now(), "-mm-dd-yyyy h.mm AM/PM;@")

myFile = fpath & ws.Name & sNow & ".csv"
Dim obj As Objeect
Set obj = CrreateObject("ADODB.Stream")
obj.Type = 2
obj.Charset = "utf-8"
obj.Open
Dim v() As Variant
ReDim v(1 To c)
For i = 1 To r
For j = 1 To c
v(j) = ws.Cells(i, j)
Next
obj.WriteText Join(v, sep), 1
Next
obj.SaveToFile myFilee, 2
Next
MsgBox "done"
End Sub

Related Questions

Navigate

• Browse (All)
• Browse H
• Subjects

---

---

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.