I am creating a macro of the report generator that let the user to save a copy of the file to its destination.
Cell value ("E5") is where the user input the date.
Cell value ("E11") is where user keyin the record name (in this case colour values)
The macro will save it to the location in the C drive
Here are the code :
Sub CTemplate()
'Select up the macro generator
Sheets("File Generator").Select
'Save file according to the textbox values
Dim filename As String
Dim varDatevalue As String
Dim varColourvalue As String
varDatevalue = Range("E5").Value
varColourvalue = Range("E11").Value
ActiveWorkbook.SaveAs filename:="C:\Colour Log\" & varDatevalue & "--" & varColourvalue & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
However, there are some problems as I encounter to run time error:
I already tried as followed:
Debugging and search for SO but couldn't find any one else with the same problems
I already created the folder at the desired locations
Uncheck ("Read Only") check box for the file so it can be written
Thank you .
"A filename cannot contain any of the following characters: \ / : * ? " < > |" - your file name seems to be "5\11\4192C700" which effectively means that you are trying to save your file in a non-existent directory c:\Colour Log\5\11\4192C700. You have to change the slashes in the file name for other characters.
The '\ / : * ? < > | [ ] "' Issue
Sub CTemplate()
'Always place values, especially text into constants, so you can
'quickly change them and you don't have to search and change them
'wherever they appear in the code.
Const cStrPath As String = "C:\Colour Log\"
Const cStrWsName As String = "File Generator"
Const cStrDateCell As String = "E5"
Const cStrColorCell As String = "E11"
Dim arrNope As Variant
Dim strNope As String
Dim strFileName As String
Dim strDate As String
Dim strColour As String
Dim intNope As Integer
'Characters you can't have in a filename
strNope = "\ / : * ? < > | [ ] " & Chr(34) 'Chr(34) is double quotes (")
'You can add other characters like "." if you don't want them in the
'filename, just make sure to separate the characters and end the string
'with a space (" ").
'Paste the characters into an array
arrNope = Split(strNope)
'Calculate strings
With Worksheets(cStrWsName)
'Loop through the array of characters
For intNope = LBound(arrNope) To UBound(arrNope)
'With 'Cstr' you coerce each value to a string data type.
'With 'Replace' you replace each character with "", practically you
'delete each 'unwanted' character if it is found.
strDate = Replace(CStr(.Range(cStrDateCell).Value), _
arrNope(intNope), "")
Next
'Coerce the value to a string datatype
strColour = CStr(.Range(cStrColorCell).Value)
End With
'Calculate filename
strFileName = cStrPath & strDate & "--" & strColour & ".xlsm"
'The following line is used only to suppress the error that could occur when
'a file already exists and at the prompt "No" or "Cancel" is selected.
On Error Resume Next
'Save the file
ActiveWorkbook.SaveAs filename:=strFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub
Related
I have code that works to add a path to a name in the name manager, but only for local paths. When I try to use a network path, the name manager adds a colon before the first single backslash, which keeps the path from working. I have added code to debug, to remove colons, which it seems wasn't necessary. The File open dialog does return the correct path. VBA writes it like this with debug.print:
`="\\win10box3\business\... ..." `
When excel stores it in the name manager it stores it like this
`="\\Win10Box3:\Business\... ..." `
I wrote code to remove the colon before adding the name, but I'm finding the path debug.prints correct before it is stored in the Name Manager, even before the loop to remove the colon.
The only solution I have found is to manually edit the path in the name manager to remove the colon
Sub GetPath()
Debug.Print "Start GetPath routine"
'This sub gets the path to a File defined by the user within the routine
'It then calls another sub that applies that path to a name in the worksheet.
' Before calling this routine, The name should first be searched for, and then verified, then opportunity given to change the name.
Dim MyPath As String 'String to hold the path to an excel spreadsheet exported from quickbooks
Dim NametoChange As String 'String that holds the name manager name to store the path under
Dim NameComment As String 'Comment to identify the name in the name manager
Dim PathLength As Long
Dim PathTemp As String
NametoChange = "PathToEmployeeWithholding"
NameComment = "This Name contains the Path to the 'Employee Withholding' worksheet exported from quickbooks using VBA"
MyMessage = "If you have not already exported and" & vbCrLf & "saved the employee withholding data from Quickbooks," & vbCrLf & "Please choose cancel and export it now"
DoIt = MsgBox(MyMessage, vbOKCancel)
Debug.Print DoIt
If DoIt = vbCancel Then
Exit Sub
End If
With Application.FileDialog(msoFileDialogFilePicker)
If .Show <> 0 Then
MyPath = .SelectedItems(1)
End If
End With
Debug.Print MyPath 'NOTE:This is producing the correct path. It has no colon here...
'Where is the colon coming from?
'IT SEEMS NECESSARY TO REMOVE A COLON IF THE PATH IS A NETWORK PATH
'FIRST VERIFY IT IS NOT A DRIVE PATH... SHOULD BE IN THE FORM OF D:\
'WHAT IS UNIQUE IS THE COLON IS THE 2ND CHARACTER IN THE PATH IF A LOCAL DRIVE.
'TEST TO SEE IF THE INCREMENT IS 2. IF IT IS, SKIP IT, AND REMOVE ALL OTHER COLONS
PathLength = Len(MyPath)
For i = 1 To PathLength
If Not i = 2 Then
If Not Mid(MyPath, i, 1) = ":" Then
PathTemp = PathTemp & Mid(MyPath, i, 1)
End If
Else
PathTemp = PathTemp & Mid(MyPath, i, 1)
End If
Debug.Print "i = " & i & " The current Character is " & _
Mid(MyPath, i, 1) & xlcrlf & "the current PathTemp is " & PathTemp
Next
MyPath = PathTemp
Debug.Print MyPath
Debug.Print "Calling ChangeValueOfName Routine"; vbCrLf & vbCrLf
Call ChangeValueOfName(NametoChange, MyPath, NameComment) 'this routine stores the retrieved text string in the name manager
Debug.Print "Exit GetPath Routine" & vbCrLf & vbCrLf
End Sub
Sub ChangeValueOfName(NametoChange As String, NewNameValue As String, Comment As String)
Debug.Print "Start changeValueOfName routine"
' ChangeValueOfNameManagerName Macro
' Changes the Value of a defined name in the Name Manager
'This should be used to change the name.
'Once the file is selected data needs to be imported to an array, and the
'Employee name values need to be checked against the worksheets in the workbook and against the recap sheet
'If changes are needed, it needs to write them into the workbook, including changing recap sheet and adding
'worksheets for any new employees
With ThisWorkbook.Names(NametoChange)
.Name = NametoChange
.Comment = Comment
RefersToR1C1 = _
"=" & Chr(34) & NewNameValue & Chr(34)
End With
Debug.Print "The New Path added is " & "=" & Chr(34) & NewNameValue & Chr(34)
Debug.Print "Return from ChangeValueOfName routine" & vbCrLf & vbCrLf
End Sub
I need to open a file whose full filename I do not know.
I know the file name is something like.
filename*esy
I know definitely that there's only one occurrence of this file in the given directory.
filename*esy is already a "shell ready" wildcard & if thats alway the case you can simply;
const SOME_PATH as string = "c:\rootdir\"
...
Dim file As String
file = Dir$(SOME_PATH & "filename*esy" & ".*")
If (Len(file) > 0) Then
MsgBox "found " & file
End If
Just call (or loop until empty) file = Dir$() to get the next match.
There is an Application.FileSearch you can use (see below). You could use that to search for the files that match your pattern. This information taken from here.
Sub App_FileSearch_Example()
With Application.FileSearch
.NewSearch
.LookIn = "c:\some_folder\"
.FileName = "filename*esy"
If .Execute(SortBy:=msoSortByLastModified, SortOrder:=msoSortOrderDescending) > 0 Then
For i1 = 1 To .FoundFiles.Count
' do something with matched file(s)
Next i1
End If
End With
End Sub
If InStr(sFilename, "filename") > 0 and InStr(sFilename, "esy") > 0 Then
'do somthing
end if
Or you can use RegEx
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "filename(.*)esy"
End With
Set REMatches = RE.Execute(sFilename)
REMatches(0) 'find match
I was trying this question as a function. This is the solution that ended up working for me.
Function fileName(path As String, sName As String, ext As String) As Variant
'path is Full path from root. Can also use path = ActiveWorkbook.path & "\"
'sName is the string to search. ? and * are wildcards. ? is for single char
'example sName = "book?" or sName ="March_*_2014*"
'ext is file extention ie .pdf .xlsm .xls? .j*
Dim file As Variant 'Store the next result of Dir
Dim fname() As String 'Dynamic Array for result set
ReDim fname(0 To 0)
Dim i As Integer ' Counter
i = 0
' Use dir to search and store first result
fname(i) = path & Dir(path & "\" & sName & ext)
i = i + 1
'Load next result
file = Dir
While file <> "" 'While a file is found store that file in the array
ReDim Preserve fname(0 To i) As String
fname(i) = path & file
file = Dir
Wend
fileName = Application.Transpose(fname) 'Print out array
End Function
This works for me as a single or array function.
If you know that no other file contains "filename" and "esy" in that order then you can simply use
Workbooks.Open Filename:= "Filepath\filename*esy.*"
Or if you know the number of missing characters then (assuming 4 characters unknown)
Workbooks.Open Filename:= "Filepath\filename????esy.*"
I use this method to run code on files which are date & timestamped to ignore the timestamp part.
Another user greatly helped me with this but I am stuck on a few parts.
The purpose of the macro:
The purpose is to take the fifth element number in the current file path then rename the file with that number and a string following it. Then I want to convert it to CSV from XLSM
The comments I have outlined explain what each block code's description is. I am not sure how to change it so that I need not to use CONST since I want to find a variable that is found at run-time and const only uses compile-time.
Const original is meant to be assigned the current workbook. I do not want a hardcoded file path in the macro.
Ensuring that the xlsm copy is left alone but renamed so that it matches XLSM
There will be a CSV copy and a XLSM copy
The file path that I have been testing on is R:\3.0 Projects\2.0 Current Projects\2021 JOBS\999111-DO-Customer-Description\2.0 Estimate\2.7 Final Estimates\FoundationImport-TMP-IFI-REV12.XLSM
I want the final file to be " R:\3.0 Projects\2.0 Current Projects\2021 JOBS\999111-DO-Customer-Description\2.0 Estimate\2.7 Final Estimates\999111import-TMP-IFI-REV12.XLSM
I appreciate your guys help greatly!
Function getName(pf): getName = Split(Mid(pf, InStrRev(pf, "\") + 1), ".")(0): End Function
Sub Snippet()
Const Original As String = "R:\3.0 Projects\2.0 Current Projects\2021 JOBS\999111-DO-Customer-Description\" & _
"2.0 Estimate\2.7 Final Estimates\FoundationImport-TMP-IFI-REV12.XLSM"
'Original = getName(ActiveWorkbook.FullName)
Dim Ext As String ' file extension
Dim Fn As String ' file name
Dim Path As String ' file path
Dim Ffn As String ' full file name
Dim Sp() As String
Dim CSVfile
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Foundation Budget Template")
' extracts number from 5th element and applies to file name
Sp = Split(Original, "\")
Fn = Sp(UBound(Sp))
Sp(7) = Split(Sp(4), "-")(0) & "import-TMP-IFI-REV12"
Ffn = Join(Sp, "\")
MsgBox "Original Ffn: " & Original & vbCr & vbCr & _
"Changed 5th element: " & Ffn
'Convert file from XLSM to CSV
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=CSVfile, FileFormat:=xlCSV, local:=True
' append a file name to path
Sp = Split(Path, "\")
Fn = "My File Name" & "." & Ext
ReDim Preserve Sp(UBound(Sp) + 1)
Sp(UBound(Sp)) = Fn
Ffn = Join(Sp, "\")
MsgBox "Full File Name = " & Ffn
End Sub
I have a txt file and I need to input it into a string array, where each line is one item in the array.
I've done a good deal with vba before but never editing files other than Word and Excel, so this is new to me.
The below is part of my sub (copied from somewhere online so I don't really understand it)
Sub TxtFileToArray(FilePath As String, LineArray As Variant, Optional Delimiter As String = vbCrLf)
'adapted from https://www.thespreadsheetguru.com/blog/vba-guide-text-files
Dim TextFile As Integer
Dim FileContent As String
'Open the text file in a Read State
TextFile = FreeFile
Open FilePath For Input As TextFile
'Store file content inside a variable
FileContent = Input(LOF(TextFile), TextFile)
'Close Text File
Close TextFile
It fails on the line FileContent = Input(LOF(TextFile), TextFile). Error message is:
Run-time error '62':
Input past end of file
The Variable Textfile = 1, and LOF(Textfile) = 4480
What should I do?
EDIT:
The File is full of xml data (it's actually an .odc file that's been converted to .txt). Is there something I should be doing to convert it all that to a string? Perhaps I could import it as a huge string somehow and then split it into the array?
Text File to Array
This is just an addition to a possibly upcoming answer, to show how you can use a function for your task (I don't know exactly what binary or a binary file is).
In my short investigation, it was tested with a json file. Interesting to me is that it works with Input and Binary, and that it needs vbLf instead of vbCrLf as the Delimiter.
Note that you might get one value in the array if you choose the wrong delimiter, like it happened in this case.
The test procedure will write the lines (the values in the array) to the cells in column A of the ActiveSheet.
The Code
Option Explicit
Sub TESTtextFileToArray()
Const FilePath As String = "F:\Test\2020\TXT\test.json"
Dim TextLines As Variant
' Note the 'vbLf' instead of 'vbCrLf'.
TextLines = TextFileToArray(FilePath, vbLf)
If Not IsEmpty(TextLines) Then
' Note that 'Transpose' has a 65536 limit per dimension.
Range("A1").Resize(UBound(TextLines) + 1).Value _
= Application.Transpose(TextLines)
'Debug.Print Join(TextLines, vbLf)
MsgBox "Found " & UBound(TextLines) + 1 & " lines."
Else
MsgBox "No lines found."
End If
End Sub
' The result is a 0-based 1D array.
Function TextFileToArray( _
ByVal FilePath As String, _
Optional Delimiter As String = vbCrLf) _
As Variant
Const ProcName As String = "TextFileToArray"
On Error GoTo clearError
Dim TextFile As Long
TextFile = FreeFile
Open FilePath For Input Access Read As TextFile
On Error Resume Next
TextFileToArray = Split(Input(LOF(TextFile), TextFile), Delimiter)
On Error GoTo clearError
Close TextFile
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
The easiest way is to use a Scripting.Dictionary and the FileSystemObject.
Public Function GetAsStrings(ByVal ipPath As String) As Variant
Dim myFso As Scripting.FileSystemObject
Set myFso = New Scripting.FileSystemObject
Dim myfile As TextStream
Set myfile = myFso.OpenTextFile(ipPath, Scripting.IOMode.ForReading)
Dim myStrings As Scripting.Dictionary
Set myStrings = New Scripting.DIctionary
Do Until myfile.AtEndOfStream
myStrings.Add mystrings.count, myfile.ReadLine
Loop
myfile.Close
Set GetAsStrings = myStrings.Items
End Function
Everything is working for me in sending an email with an attachment from Excel using Visual Basic via Thunderbird when the attachment path is hard-coded.
attachment=C:\Users\Desktop2017\Desktop\customer\customerNumber\invoiceNumber.pdf"
But I need to change part of the file path for attachment based on what's in cell M4 and have the file name change based on what's in cell J4.
Example: M4 value is currently 101. J4 value is currently 2000-01. The output should be "C:\Users\Desktop2017\Desktop\customer\101\2000-01.pdf"
I have tried using 'Range' to get the value and setting a string but instead of getting the data from the cell or string it just outputs whatever I have after the equals sign.
I've tried adding and moving quotation marks around but nothing has worked at this point.
Thanks in advance for any help, Dalton.
PS: Sorry for hobbled together code.
Private Sub EmailInvoice_Click()
Dim FileNumber As Integer
Dim retVal As Variant
Dim strName As String
Dim strFile As String
Dim wsCustomer As Worksheet
strName = Range("Q2").Value
strFile = Dir(strFolder & "*.xlsx")
Const MY_FILENAME = "C:\Users\Desktop2017\Dropbox\temp\invoice.BAT"
FileNumber = FreeFile
'create batch file
Open MY_FILENAME For Output As #FileNumber
Print #FileNumber, "cd ""C:\Program Files (x86)\Mozilla Thunderbird"""
Print #FileNumber, "thunderbird -compose"; _
" to=" + ThisWorkbook.Sheets("hourlyInvoice01").Range("N21") _
+ ",subject=Invoice " + ThisWorkbook.Sheets("hourlyInvoice01").Range("J4") + ",format="; 1; _
",body=""<HTML><BODY>Hello "; ThisWorkbook.Sheets("hourlyInvoice01").Range("N20") _
+ ",<BR><BR>Please see attached.<BR><BR>Thanks, Dalton.<BR><BR><BR>Contact Info Text Line 1<BR>Contact Info Text Line 2<BR>Contact Info Text Line 3</BODY></HTML>"",attachment=C:\Users\Desktop2017\Desktop\test\script\someFile.txt"
Print #FileNumber, "exit"
Close #FileNumber
'run batch file
retVal = Shell(MY_FILENAME, vbNormalFocus)
' NOTE THE BATCH FILE WILL RUN, BUT THE CODE WILL CONTINUE TO RUN.
If retVal = 0 Then
MsgBox "An Error Occured"
Close #FileNumber
End
End If
'Delete batch file
'Kill MY_FILENAME
End Sub
Add this before that line
Dim FlName As String
FlName = "C:\Users\Desktop2017\Desktop\customer\" & Range("M4").Value & "\" & Range("J4").Value & ".pdf"
and then change the line
",<BR><BR>Please see attached.<BR><BR>Thanks, Dalton.<BR><BR><BR>Contact Info Text Line 1<BR>Contact Info Text Line 2<BR>Contact Info Text Line 3</BODY></HTML>"",attachment=C:\Users\Desktop2017\Desktop\test\script\someFile.txt"
to
",<BR><BR>Please see attached.<BR><BR>Thanks, Dalton.<BR><BR><BR>Contact Info Text Line 1<BR>Contact Info Text Line 2<BR>Contact Info Text Line 3</BODY></HTML>"",attachment=" & FlName
Note: To concatenate strings, use & instead of +