I have a macro that executes and creates a PDF file. Each time the macro is run, a PDF is generated. I would like to move the last version of the report (run three times per day) to a folder titles 'Past Reports'. I have been playing around with the script below but it does not work for me. The Active Report folder only contains the most recent PDF created.
Can anyone offer help? Happy to add more info if needed.
Public Sub transferFile()
On Error GoTo nextIt
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
PDFPath = "D:\####\Pinging Program\Active Report\"
pastPDFPath = "D:\####\Pinging Program\Past Reports"
sSourceFile = PDFPath & Dir(PDFPath & "*.pdf")
sDestinationFile = "D:\####\Pinging Program\Past Reports"
'move file
If Dir(sSourceFile) <> "" Then
fileSystemObject.moveFile sSourceFile, sDestinationFile
End If
nextIt:
End Sub
Your destination folder is missing the final slash. Also as a suggestion for the future the error would have been a lot easier to understand if you weren't bypassing error handling as Victor had suggested. Your code would look like:
Public Sub transferFile()
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
PDFPath = "C:\test\Active Report\"
pastPDFPath = "C:\test\Past Reports"
sSourceFile = PDFPath & Dir(PDFPath & "*.pdf")
sDestinationFile = "C:\test\Past Reports\"
'move file
If Dir(sSourceFile) <> "" Then
fileSystemObject.moveFile sSourceFile, sDestinationFile
End If
End Sub
I have tested it and it worked as expected. Regards,
Related
I have a list of file names in a worksheet. I want to read a name, find the actual file, rename it and move on to the next name.
The 1st part, retrieving the name from the worksheet and modifying it to the new name is not a problem. The problem is assigning the new name to the file.
The Name function does not work because the files are on a different drive. I also tried Scripting.FileSystemObject.
The code runs but no change is made.
Here is the code I used...
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.GetFile(fOldName)
If Not Err = 53 Then 'File not found
'Rename file
f.Name = fNewName
End If
Did I make a code mistake I'm not seeing? Should I be using/doing something else?
Finding info on VBA and/or VB6 is getting pretty rare these days.
BTW. This is for Excel 2016.
Tks
If there was no misunderstanding...
FSO... it's bad in any case. It's just a bugsful API wrapper, written with a left chicken paw.
There are pure VB & API for more sophisticated cases.
No external libs & objects:
Public Sub sp_PrjFilMov()
Dim i As Byte
Dim sNam$, sExt$, sPthSrc$, sPthTgt$, sDir$
sPthSrc = "V:\"
sPthTgt = "R:\"
sNam = "Empty_"
sExt = ".dmy" ' dummy
For i = 1 To 5 ' create set of files for test
Call sx_CrtFil(i, sPthSrc, sNam, sExt)
Next
sDir = Dir(sPthSrc & "*" & sExt, vbNormal) ' lookup for our files ..
Do
'Debug.Print sDir
Select Case LenB(sDir)
Case 0
Exit Do ' *** EXIT DO
Case Else
Call sx_MovFil(sPthSrc, sDir, sPthTgt) ' .. & move them to another disk
sDir = Dir
End Select
Loop
Stop
End Sub
Private Sub sx_CrtFil(pNmb As Byte, pPth$, pNam$, pExt$)
Dim iFilNmb%
Dim sFilNam$
sFilNam = pPth & pNam & CStr(pNmb) & pExt
iFilNmb = FreeFile
Open sFilNam For Output As #iFilNmb
Close #iFilNmb
End Sub
Private Sub sx_MovFil(pPnmSrc$, pFnm$, pPthTgt$)
Dim sSrcPne$
sSrcPne = pPnmSrc & pFnm
'Debug.Print "Move " & sSrcPne & " --> " & pPthTgt
Call FileCopy(sSrcPne, pPthTgt & pFnm)
Call Kill(sSrcPne)
End Sub
'
I'm trying to add a few custom document properties to a folder of word documents.
I know that the loop itself works fine, because I used the same loop with different code to modify and then update pre-existing custom document properties.
The code to add custom document properties also works, I tested it by running it in it's own macro for a single document, which worked fine.
Since the loop works and the code within the loop also works, I just can't figure out what's wrong with it.
Here's the code:
Sub add_custom_docproperties()
Dim file
Dim path As String
Dim filepath As Variant
filepath = InputBox("Please enter the filepath for the files you want to
update.", "Input Filepath", "Copy filepath here...")
Select Case StrPtr(response)
Case 0
endednotification = MsgBox("The macro has been ended.", , "Notification")
Exit Sub
Case Else
End Select
path = filepath & "\"
file = Dir(path & "*.*")
'Application.ScreenUpdating = False
Do While file <> ""
Documents.Open FileName:=path & file
Check = MsgBox(path & file, , "Check")
ActiveDocument.CustomDocumentProperties.Add Name:="firstdocprop",
_LinkToContent:=False, Type:=msoPropertyTypeString, Value:="The First One"
ActiveDocument.CustomDocumentProperties.Add Name:="seconddocprop",
_LinkToContent:=False, Type:=msoPropertyTypeString, Value:="Second"
ActiveDocument.CustomDocumentProperties.Add Name:="thirddocprop",
_LinkToContent:=False, Type:=msoPropertyTypeString, Value:="Third"
'original example from:
'https://msdn.microsoft.com/en-us/vba/office-shared-vba
/articles/documentproperties-add-method-office
ActiveDocument.Save
ActiveDocument.Close
'set file to next in Dir
file = Dir()
Loop
'Application.ScreenUpdating = True
MsgBox "The macro is complete."
End Sub
As you can see I have a comment there with the first example I tried from msdn, which I modified.
Thanks in advance for any help, even if you could just point me to a resource explaining where I've gone wrong or something like that.
Word does not recognise the changes to the CustomDocumentProperties as being sufficiently important to actually save the document when you execute the Save command - unless you had made other changes it just decides to ignore the Save.
You can force a save by telling Word that the document has not been saved since it was last changed:
ActiveDocument.Saved = False
ActiveDocument.Save
ActiveDocument.Close
This seems so simple and I've had it working multiple times, but something keeps breaking between my Dir call (to iterate through a directory) and opening the current file. Here's the pertinent code:
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
'Start looping through directory
While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceCurrentFile)
What I get with this is a file access error as the Application.Workbooks.Open is trying to open "C:\ExcelWIP\TestSource\\FILENAME" (note extra slash)
However when I take the final slash out of SourceLoc, the results of Dir(SourceLoc) are "" (it doesn't search the directory).
The frustrating thing is that as I've edited the sub in other ways, the functionality of this code has come and gone. I've had it work as-is, and I've had taking the '/' out of the directory path make it work, and at the moment, I just can't get these to work right together.
I've scoured online help and ms articles but nothing seems to point to a reason why this would keep going up and down (without being edited except for when it stops working) and why the format of the directory path will sometimes work with the final '/' and sometimes without.
any ideas?
This would open all .xlxs files in that directory son.
Sub OpenFiles()
Dim SourceCurrentFile As String
Dim FileExtension as String: FileExtension = "*.xlxs"
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
SourceCurrentFile = Dir()
'Start looping through directory
Do While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceLoc &"\"& SourceCurrentFile)
SourceCurrentFile = Dir(FileExtension)
Loop
End Sub
JLILI Aman hit on the answer which was to take the results of Dir() as a string. Using that combined with the path on Application.Open allows for stable behaviors from the code.
New Code:
Dim SourceLoc as String
Dim SourceCurrentFile as String
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
'Start looping through directory
While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceLoc & "/" & SourceCurrentFile)
I didn't include the recommended file extension because I'm dealing with xls, xlsx, and xlsm files all in one directory. This code opens all of them.
Warning - this code will set current file to each file in the directory including non-excel files. In my case, I'm only dealing with excel files so that's not a problem.
As to why this happens, it does not appear that Application.Open will accept the full object results of Dir(), so the return of Dir() needs to be a String. I didn't dig deeper into the why of it beyond that.
Consider using VBA's FileSystemObject which includes the folder and file property:
Sub xlFilesOpen()
Dim strPath As String
Dim objFSO As Object, objFolder As Object, xlFile As Object
strPath = "C:\ExcelWIP\TestSource"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
For Each xlFile In objFolder.Files
If Right(xlFile, 4) = "xlsx" Or Right(xlFile, 3) = "xls" Then
Application.Workbooks.Open (xlFile)
End If
Next xlFile
Set objFSO = Nothing
Set objFolder = Nothing
End Sub
I am a professor in an English department, and my composition students often write multiple drafts of their essays. I use Word 2010 to track their changes.
I discovered VBA code on another site (located here). I created a new macro. It prompts me correctly for the base, new, and comparison folders, but the output is null.
I have the files in both the base and new folders named identically and saved in .doc format. I also set the trust center options in Word to 1) enable all macros and 2) trust access to the VBA project object model.
Sub CompareAllFiles()
Dim strFolderA As String
Dim strFolderB As String
Dim strFolderC As String
Dim strFileSpec As String
Dim strFileName As String
Dim objDocA As Word.Document
Dim objDocB As Word.Document
Dim objDocC As Word.Document
strFolderA = InputBox("Enter path to base documents:")
strFolderB = InputBox("Enter path to new documents:")
strFolderC = InputBox("Enter path for document comparisons to be saved:")
strFileSpec = "*.doc"
strFileName = Dir(strFolderA & strFileSpec)
Do While strFileName <> vbNullString
Set objDocA = Documents.Open(strFolderA & strFileName)
Set objDocB = Documents.Open(strFolderB & strFileName)
Application.CompareDocuments _
OriginalDocument:=objDocA, _
RevisedDocument:=objDocB, _
Destination:=wdCompareDestinationNew
objDocA.Close
objDocB.Close
Set objDocC = ActiveDocument
objDocC.SaveAs FileName:=strFolderC & strFileName
objDocC.Close SaveChanges:=False
strFileName = Dir
Loop
Set objDocA = Nothing
Set objDocB = Nothing
End Sub
If you and your students are using Word 2010 then the extension would most likely be .docx:
strFileSpec = "*.docx"
Have you tried running the code step-by-step with the VBA debugger, to see what is the exact point of failure? See here (under the section entitled Stepping Through Code) for a simple introduction.
Some kind VBA guru figured it out for me: I need to enter a \ at the end of the folder paths. Without the final backslash, the script was not able to locate the folders, and thus it wasn't processing any files. After adding the final \ to all three folder paths, the code ran perfectly.
As a bonus, the code processes both .doc and .docx files. I thought I was going to have to convert all my .docx files to .doc before processing, but the code is smarter than that.
Eureka!
I have an application that exports daily reports in txt format.
I have a macro that extracts certain lines of data from those reports and puts them in an output xls file. my macro's input directory is curently a separate folder that i manually move today's reports into.
I'd like for my macro to be able to just read from the default report folder and only read files created with today's date.
the naming convention of the report files is as follows:
1101_16_16_AppServiceUser_YYYYMMDDhhmmssXXX.txt
not sure what the last 3 digits on the file name represents, but they're always numbers.
Help?
WOW that was fast! thanks... fist time using stackoverflow.
I guess i should include the code that pulls data and dumps it to excel... here it is:
Sub PullLinesFromEPremisReport()
Dim FileName, PathN, InputLn As String
Dim SearchFor1, SearchFor2, OutpFile As String
Dim StringLen1, StringLen2 As Integer
Dim colFiles As New Collection
Dim bridgekey As String
PathO = "C:\Documents and Settings\GROMERO\Desktop\CM reconciliation\output\"
PathN = "C:\Documents and Settings\GROMERO\Desktop\CM reconciliation\input\"
FileName = Dir(PathN)
While FileName <> ""
colFiles.Add (FileName)
FileName = Dir
Wend
SearchFor1 = "BRIDGE KEY"
StringLen1 = Len(SearchFor1)
OutpFile = "RESULTS.xls"
Open PathO & OutpFile For Output As #2
For Each Item In colFiles
Open PathN & Item For Input As #1
Do Until EOF(1) = True
Line Input #1, InputLn
If (Left(LTrim$(InputLn), StringLen1) = SearchFor1) Then
bridgekey = InputLn
End If
Loop
Close #1
Next Item
Close #2
End Sub
Daniel's answer is correct, but using the FileSystemObject requires a couple of steps:
Make sure you have a reference to "Microsoft Scripting Runtime":
Then, to iterate through the files in the directory:
Sub WorkOnTodaysReports()
'the vars you'll need
Dim fso As New FileSystemObject
Dim fldr As Folder
Dim fls As Files
Dim fl As File
Set fldr = fso.GetFolder("C:\Reports")
Set fls = fldr.Files
For Each fl In fls
'InStr returns the position of the substring, or 0 if not found
' EDIT: you can explicitly use the reliable parts of your file name
' to avoid false positives
If InStr(1, fl.Name, "AppServiceUser_" & Format(Now, "YYYYMMDD")) > 0 Then
'Do your processing
End If
Next fl
End Sub
EDIT: So I think, from the code you posted, you could send PathN to the main Reports folder like you desire, then just modify your While statement like so:
While FileName <> ""
If InStr(1, FileName, "AppServiceUser_" & Format(Now, "YYYYMMDD")) > 0 Then
colFiles.Add (FileName)
End If
FileName = Dir
Wend
Two ways you can do this off the top of my head. Assuming you are using a File via the FileSystemObject.
Do an Instr on the file.Name looking for Format(Date, "YYYYMMDD") within the string.
Or use a far simpler approach loop through the files and within your loop do this:
If File.DateCreate >= Date Then
'Do something
end if
Where File is the actual variable used to for looping through the files.
If fileName like "*AppServiceUser_" & Format(Now, "YYYYMMDD") & _
"#########.txt" Then
'good to go
End If