VBA CopyFolder copying wrong folder - excel

I've got a small macro that is supposed to copy a folder and all its contents from one filepath to another. The problem is, it's copying the wrong folder. It instead copies the first subfolder (but not its contents) from that folder and then errors out with a "Path not found" error. Occasionally it will copy the main folder and then just that same first subfolder with none of its contents and then again error out with "Path not found".
Dim strFilePath As String, techfolder As String
strFilePath = "G:\Data\FolderName\PROJECTS\2019\AnotherFolderName\Test_Area\" & year2 & " - Testing\6. Verification\" & quarter & "\3 - Verification Emails Received\YetAnotherFolderName"
techfolder = "G:\Data\CompanyName\FolderName\AnotherFolderName\Name" & year2 & " " & quarter2 & "\Completed\"
Dim FSO As Object
If Right(techfolder, 1) = "\" Then
techfolder = Left(techfolder, Len(techfolder) - 1)
End If
If Right(strFilePath, 1) = "\" Then
strFilePath = Left(strFilePath, Len(strFilePath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(techfolder) = False Then
MsgBox techfolder & " doesn't exist"
Exit Sub
End If
Debug.Print (strFilePath)
Debug.Print (techfolder)
FSO.CopyFolder Source:=techfolder, Destination:=strFilePath
MsgBox "You can find the files and subfolders from " & techfolder & " in " & strFilePath
I've tried a couple different methods of the CopyFolder with if logic, etc. from some internet searches but all in this general form. None of them copy the folder and all its subfolders/contents correctly.
I've checked my filepaths via the debug, they are fine and I can copy/paste them into file explorer and navigate with no issue. Additionally the subfolder copying implies that it seems to be correct.
Manually copying the folder or its subfolder has no issues.
ETA: There are about 31 sub folders and each contains one excel and one pdf.
Variable Values are:
Quarter is Q3 2018
Year2 is 2018
Quarter2 is Q3
Year2 and Quarter2 are made by substrings of Quarter, a variable that is populated via an inputbox.
year2 = Mid(quarter, 4, 4)
quarter2 = Mid(quarter, 1, 2)

Related

Unable to copy files (.pdf/.jpeg/.jpg) from one folder to another

Using 2010 Excel VBA - I need to use look up the image/pdf with the Branch Code as a part of its name at "C:\ECB Test\ECB IR COPY" and paste it at "C:\ECB Test\" RO if it exists. If it doesn't, the program needs to highlight the Branch Code.
(File Name Examples: 28-Kochi-ecb-sdwan completed.pdf, 23 eCB Kozhikode completed.pdf/0036.jpeg)
Having done this manually twice for two other excel sheets (4k+ cells), I decided to Frankenstein a module together and, well, it does not work and I have no idea why.
Sub Sort()
Const SRC_PATH As String = "C:\ECB Test\ECB IR COPY"
Const DEST_PATH As String = "C:\ECB Test"
Dim Row_Number As Integer
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Dim Folder_Name As String
Dim Branch_Code As String
Dim Final_Path As Variant
Dim File As String
For Row_Number = 3 To 2465
Branch_Code = Worksheets("WAN RFP").Cells(Row_Number, 2)
Folder_Name = Worksheets("WAN RFP").Cells(Row_Number, 5)
On Error Resume Next
File = Dir(SRC_PATH & "\*" & Branch_Code & "*")
Final_Path = Dir(DEST_PATH & "\" & Folder_Name & "\")
If (Len(File) > 0) Then
Call fso.CopyFile(File, Final_Path)
Else
Cells(Row_Number, 2).Interior.ColorIndex = 6
End If
On Error GoTo 0
DoEvents
Next Row_Number
End Sub
I think its unable to use the Branch Code variable as a wildcard, though I might as well have done something silly somewhere in the code. Can someone please help me out?
The problem is you are using the destination path instead of the source path:
File = Dir(DEST_PATH & "*" & Branch_Code & "*.*")
Change it to
File = Dir(SRC_PATH & "*" & Branch_Code & "*.*")

Search windows, returns filepath

OK, so I have code that will take the data entered in "A3" and open a widows search with "*" + A3's contents. What I need now is when any file is found with that search to find the folder name that houses it. Basically we have prints stored by a random number not associated to the real part number but all the related prints are stored within this random numbered folder.
Example:
C:\Document Control\Master Prints*12345*\printxyz.pdf
If I were to search for "*xyz" and "printxyz.pdf" shows up, I now need the "12345" folder name to populate in a cell.
Here is what im using so far
Sub Macro4()
Dim var As Variant
var = "*" & Range("A3").Value
Call Shell("explorer.exe " & Chr(34) & "search-ms:query=" & var & "&crumb=location:""C:\Document Control\Master Prints" & Chr(34), vbNormalFocus)
End Sub
I did something similar recently. I had words in cell E1 that pertains to files in a folder. So I did an instr on the first 5 letters of that cell as my search then looped through the folder to find the file containing that string.
You should be able to adapt this code to what you need.
Const parentFolder As String = "I:\this\that\"
subFolder = parentFolder & getFoldPath(parentFolder, Left(.Range("E1"), 5)) & "\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(subFolder)
For Each oFile In oFolder.Files
If InStr(oFile, Left(.Range("E1"), 5)) > 0 Then
scope = subFolder & oFile.name
End If
Next

Pulling file names from SharePoint and saving to SharePoint, using VBA

I'm trying to adapt an Excel form I created that uses drive locations to save copies of the form, to work with SharePoint in a similar manner. Currently, the first macro is set up such that it will search the contents of a particular folder to determine the next available number in the queue (i.e. if 1, 2 and 4 already exist, it will assign 3) and save the sheet as that next available number. When the sheet is complete, the second macro will save the file with a specified name based on data within the sheet, in another specified location (again based on data defined within the sheet). The drive is in the process of being retired in our company and everything moved to Cloud-based storage, so I would like a way to complete the same actions but using SharePoint directories.
The code for the first macro is as follows:
Dim strDir As String
Dim file As Variant
Dim savename As Integer
Dim savename_string As String
strDir = "R:\Queue\"
savename = 1
savename_string = CStr(savename)
file = Dir(strDir)
While (CInt(savename_string) = savename)
If file <> (savename & ".xlsm") Then
If file = "" Then
savename = savename + 1
Else
file = Dir
End If
ElseIf file = (savename & ".xlsm") Then
savename = savename + 1
savename_string = CStr(savename)
file = Dir(strDir)
End If
Wend
ActiveWorkbook.SaveAs ("R:\Queue\" & savename_string & ".xlsm")
And then the code for the second macro is as follows:
Dim answer As Integer
Dim error As Integer
Dim delete As String
answer = MsgBox("Are you sure you want to save sheet & close?", vbYesNo + vbQuestion, "WARNING")
If answer = vbYes Then
'Define PWO, assembly, terminal, strand, and gauge As Strings, and define which cells they are on the sheet
delete = ActiveWorkbook.Name
ActiveWorkbook.SaveAs ("R:\" & terminal & assembly & Space(1) & gauge & strand & Space(1) & PWO & Space(1) & Format(Now(), "MM-DD-YYYY") & ".xlsm")
Kill ("R:\Queue\" & delete)
ActiveWorkbook.Close
Else
Exit Sub
End If
Currently the second macro works correctly when replacing the locations with the SharePoint URL locations, but when doing the same with the first macro, it returns an error message "Bad file name or number" at the line file = Dir(strDir). Can I get this code in working order, or is there a better way I should go about this? Thanks!

Excel vba Next invoice number with creation of automatic directory folder by month

Ok , here is the thing,
I have created a next invoice number program in which by pressing of a macro assigned button active invoice automatically saved and closed and the next invoice with a number increased appear.My problem is that, I want excel invoices to be created in their relevant folder by their first two digits of invoice number . as an example : 04-001 where 04 stands for April. also, when invoice number is given 05-002, the directory folder of may 2018-19 should be auto created and invoice should be there in the folder only. i am trying to figure out the code since some time but no luck till now. So far , The invoices are created according to date only but as darren said it is a problem for me when i am trying to create invoices from december on first day of january.
This is my current code :
Sub SaveInvoiceM()
Dim NewFN As Variant
If Len(Dir("C:\Invoices\" & Format(Date, "MMM YYYY") & "-" & (Format(Date, "YY") + 1), vbDirectory)) = 0 Then
MkDir "C:\Invoices\" & Format(Date, "MMM YYYY") & "-" & (Format(Date, "YY") + 1)
End If
' Copy Invoice to a New Workbook
NewFN = "C:\Invoices\" & Format(Date, "MMM YYYY") & "-" & (Format(Date, "YY") + 1) & "\Inv" & Range("F5") & ".xlsx"
ActiveWorkbook.saveas NewFN, FileFormat:=xlOpenXMLWorkbook
NextInvoice
End Sub
Range("F5") stands for my invoice number which is 04-001
I see what you are trying to do (keep nicely organized, automatically) and that's an excellent goal.
I have a suggestion of an alternate invoice numbering system (based on what I'm understanding of your situation & experience level) that will make tasks (like this "auto-filing" process) much easier, and will also simplify the process any time you (or especially anyone else) needs to look back at these invoices. There are a number of obvious benefits (same idea as metric vs imperial).
Ideal numbering system: (in my opinion)
To reduce confusion: Give each invoice and filename the same name instead of having a filename with a month and
Since you want granularity from months to years (but not days): make the invoice/file name include the all of those fields.
To make sorting & finding these logical (easier): place each "date part" in order of biggest to smallest. A unique sequential number goes at the very end.
Your code sample was a good start - I just have a bit of OCD when it comes to this kind of thing, and creation of a numbering system is an important task. (Also this will be "date-proof", and error-checked along the way...
This is a little different than what you had because instead of you telling the code what the next invoice number is, it tells you (by figuring out the next number in sequence based on the existing files).
Like yours, it creates a folder if necessary. Since the files are number YYMM-nnn then are always in the correct order when you sort them. (The "month folders" are unnecessary since the month is in the filename, but I included them anyway since that was your plan. You could just keep every month's invoices in one folder, and they'd still be organized in order of month.)
VBA #1: Save file with next sequential invoice number (creating folder if necessary)
Sub createInvoiceNumberAndSave()
'creates a new invoice number based on date in specified cell & creates new folder if necessary
'finds next unused invoice number & verifies that file is properly saved
Const invoicePath = "c:\invoices\" ' invoice root save path
Const fNamePrefix = "Inv" ' prefix for the filename
Const fNameExt = ".xlsm" ' file extension
Const getInvoiceDate = "F5" ' we GET the DATE of the invoice from F5
Const putInvoiceNumber = "F6" ' we will PUT the new filename into cell F6
Dim invDate As Date, folderName As String, fName As String, fNum As Long, nextInvoiceNum As Long
'get the invoice date and make sure it's valid
If IsDate(Range(getInvoiceDate).Value) Then
'valid date found in cell F5
invDate = Range(getInvoiceDate).Value
Else
'valid date not found in F5. Do we want to default to today's date?
If MsgBox("Cell " & getInvoiceDate & " does not contain a valid date." & vbLf & vbLf & _
"Do you want to use today's date instead?", vbQuestion + vbOKCancel, "Date not found") <> vbOK Then
Call MsgBox("Invoice Not Saved.", vbCritical + vbononly, "User Cancelled")
Exit Sub 'stop running
Else
invDate = Date 'use today's date
End If
End If
'find the next unused invoice number for this month
folderName = Format(invDate, "YYMM")
nextInvoiceNum = 0
'figure out the next unused "file number"
fName = Dir(invoicePath & folderName & "\" & fNamePrefix & folderName & "-*" & fNameExt)
If fName = "" Then
'file not found
If Dir(invoicePath & folderName, vbDirectory) = "" Then
'month not found - create folder?
If MsgBox("Okay to create folder '" & invoicePath & folderName & "' for invoice #" & folderName & "-001 ?", _
vbOKCancel + vbQuestion, "Folder not Found") <> vbOK Then Exit Sub
'create folder
MkDir (invoicePath & folderName)
End If
Else
'month found. Now find the highest invoice number in the folder.
Do While fName <> ""
Debug.Print "Found File: " & fName
'get the number (filename = fNamePrefix & "YYMM-___.xlsx" so we know where it is
If IsNumeric(Mid(fName, 6 + Len(fNamePrefix), 3)) Then 'it's a valid number
fNum = Val(Mid(fName, 6 + Len(fNamePrefix), 3))
'if it's the biggest so far, remember it
If fNum > nextInvoiceNum Then nextInvoiceNum = fNum 'biggest one so far
End If
fName = Dir
Loop
End If
'we have the next available invoice#
nextInvoiceNum = nextInvoiceNum + 1 'new invoice# (numeric)
'PUT the new invoice# (text) in cell F6
Range(putInvoiceNumber).Value = fNamePrefix & folderName & "-" & Format(nextInvoiceNum, "000")
fName = invoicePath & folderName & "\" & Range(putInvoiceNumber).Value & fNameExt
Debug.Print "Saving as: " & fName
'save file
ActiveWorkbook.SaveAs fName
'DOUBLE CHECK check that file exists (couple lines of code now save a headache later)
If Dir(fName) = "" Then
'something went wrong (file wasn't saved)
Call MsgBox("ERROR! FILE NOT SAVED: " & fName, vbCritical + vbOKOnly, "ERROR!")
Stop
End If
'success message!
Call MsgBox("Invoice saved successfully:" & vbLf & vbLf & fName, vbInformation, "Invoice Created")
'NextInvoice '?
End Sub
EDIT: ("Back to your way")
I can think of a number of ways that your method will be a problem, some of which I tried explaining, but you're determined to number & organize these files your way, so "here you go".
VBA #2: Save file with cell value as name:
This procedure saves the current file, named from the invoice number (like 04-001) that you enter in cell F5 (creating folder if necessary):
Sub SaveFileBasedOnInvoiceNumber()
Dim monthNum As Long, yearString As String, folderName As String, fName As String
'build filename
On Error Resume Next 'skip errors for now
monthNum = Val(Left(Range("F5"), 2))
yearString = Year(Date) & "-" & Right(Year(Date) + 1, 2)
folderName = "c:\invoices\" & StrConv(monthName(monthNum, True), vbUpperCase) & " " & yearString
fName = folderName & "\INV" & Range("F5") & ".xlsm"
'check if there was a problem
If Err Then MsgBox "Invalid invoice number": Exit Sub
MkDir (folderName) 'create folder
On Error GoTo 0 'turn error checking back on
'Confirm file saved properly
ActiveWorkbook.SaveAs fName 'save file
If Dir(fName) = "" Then MsgBox "Error! File not saved: " & fName: Exit Sub
MsgBox "Invoice saved successfully:" & vbLf & fName
End Sub
I'll leave "VBA #1" in the the top of the answer for others seeking a logical numbering & storage system with auto-generated invoice numbers.
(One day you'll figure out why that way would've been better, but be forewarned, it will be a lot more of a hassle to change your organization method later!)
Good luck!

ActiveWorkbook.SaveAs excel 2013 1004 error

I am getting a
Run-time error '1004' Method 'SaveAs' of object '_Workbook' failed.
The code works in excel 2010. I only get this error message in excel 2013.
The error message appears after trying to run the follow line.
ActiveWorkbook.SaveAs FolderPath & SaveName & NewSaveExt, 52
Background:
The spreadsheet is an .xls
When using the Saveas I am changing it to .xlsm
I have tried it with a .xls extension and fileformat 56 and it still falls over.
I am using code from the resources listed in the code.
I am saving the file to the same folder the workbook is in.
The orignal file name is: Financial Report as at month N.xls
The new filename is : Financial Report 1516 as at month 8.xlsm
Sub SaveNewVersion_Excel()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim NewSaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
TestStr = ""
Saved = False
x = 0
NewSaveExt = ".xlsm"
'Version Indicator (change to liking)
VersionExt = "_v"
'Pull info about file
On Error GoTo NotSavedYet
myPath = ActiveWorkbook.FullName
myFileName = "Financial Report " & FileFinancialYear & " as at month " & MonthNumber
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
'Determine Base File Name
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
'Test to see if file name already exists
If FileExist(FolderPath & SaveName & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & NewSaveExt, 52
Exit Sub
End If
'Need a new version made
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & VersionExt & x & NewSaveExt, 52
Saved = True
Else
x = x + 1
End If
Loop
'New version saved
MsgBox "New file version saved (version " & x & ")"
Exit Sub
'Error Handler
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
'RESOURCE: http://www.rondebruin.nl/win/s9/win003.htm
Dim TestStr As String
'Test File Path (ie "S:\Reports\Financial Report as at...")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
Error reproduction: I was able to reproduce the error when trying to save a workbook with a FileName that already exist.
This could happen because the code checks the existence of a file named with extension SaveExt (using Function FileExist) but then try to save it as a file named with extension NewSaveExt. If these extensions are not the same then it’s possible that the file named with extension NewSaveExt already exist raising the
Run-time error ‘1004’: Method ‘SaveAs’ of object ‘_Workbook’ failed.
However this alert:
A file ‘Financial Report as month .xlsm’ already exist in this
location. Do you want to replace it?.
Should have been displayed before the error 1004
Unfortunately I cannot test the code posted in Excel 2010, but I personally think this behavior is not exclusive of Excel 2013.
Solution: If the objective is to always save the file as xlsm (value of NewSaveExt) then the code should validate the existence of a filename with that extension.
Additional comments about the code posted:
It’s a best practice to declare all variables. These variables are not declared:
TestStr, FileFinancialYear, MonthNumber, myFileName, myArray
These lines are redundant as no need to initialize variables that have not been used as yet, so they are already holding their initialized value.
TestStr = ""; Saved = False; x = 0
Suggest to use constant instead of variables for these (see Variables & Constants)
NewSaveExt = ".xlsm"; VersionExt = "_v"
New workbooks are not detected as the error handler NotSavedYet which is supposed to be triggered when the ActiveWorkbook has not been saved before (i.e. a new workbook) never gets fired as none of the commands between the On Error statements generate an error when dealing with new workbooks (see On Error Statement). If the intention is not to save New Workbooks, as implied by the error handler NotSavedYet, then validate the Path of the ActiveWorkbook, it will be empty if the workbook has not has been saved before.
The FileFinancialYear and MonthNumber variables never get populated.
Suggest to use specific workbook properties for Path and Name instead of FullName (see Workbook Object (Excel))
About the piece referred as Determine Base File Name
a. Programming: There is no need for IF statement, just use the Split function and take the item 0. The Split function returns ”a single-element array containing the entireexpression” when the delimiter is not present in the expression” (i.e. VersionExt and myFileName respectively).
b. Practicality: This piece seems to be redundant, as it’s meant to extract from variable myFileName the filename excluding the version and extension, however there is no such information in the variable as it has been populate just few lines above as:
myFileName = "Financial Report " & FileFinancialYear & " as at month " & MonthNumber
Therefore SaveName is always equal to myFileName
The first version of the file is indexed as 0 instead of 1.
The new indexed version will not always be the last index number + 1. If any of the previous versions is deleted or moved out to another folder as this version is missing the code will assign the missing version index to the latest file saved (see Fig. 1, note that time of the version 3 is newer than versions 4 & 5). Correction of this point requires a more complex approach as such it is not included in the revised code below.
Requirements: Based on the above a revised code is written that complies with the following requirements:
The procedure resides in a standalone workbook.
Files are always saved as xlOpenXMLWorkbookMacroEnabled (Extension xlsm)
New workbooks will not be saved as new versions.
Variables FileFinancialYear and MonthNumber are hardcoded as there is no indication of how they get populated (change as required).
The first time a file is saved and it does not exist in the source folder the file will be saved without version number.
The index of the first version should be 1 (change to 0 if required).
Option Explicit
Sub Wbk_SaveNewVersion_Xlsm()
Const kExt As String = ".xlsm"
Const kVrs As String = "_v"
Dim WbkAct As Workbook
Dim iYear As Integer, bMnth As Byte, sWbkStd As String
Dim sWbkPthNme As String, bVrs As Byte
Rem Set Standard Workbook Name
iYear = 2015 'Update Financial Year as required
bMnth = 9 'Update Month as required
sWbkStd = "Financial Report " & iYear & " as at month " & Format(bMnth, "00")
Rem Validate Active Workbook
Set WbkAct = ActiveWorkbook
If WbkAct.Name = ThisWorkbook.Name Then GoTo HdeThs
If WbkAct.Path = Empty Then GoTo NewWbk
Rem Get Workbook Properties
sWbkPthNme = WbkAct.Path & "\" & sWbkStd
Rem Validate Base File Existance
If Not (Fil_FileExist(sWbkPthNme & kExt)) Then
WbkAct.SaveAs sWbkPthNme & kExt, xlOpenXMLWorkbookMacroEnabled
MsgBox "A new workbook has been created: " & _
vbLf & vbLf & Chr(34) & sWbkStd & kExt & Chr(34), _
vbApplicationModal + vbInformation, "Workbook - Save a New Version - Xlsm"
Exit Sub
End If
Rem Save a New Version
bVrs = 1
sWbkPthNme = sWbkPthNme & kVrs
Do
If Fil_FileExist(sWbkPthNme & bVrs & kExt) Then
bVrs = 1 + bVrs
Else
WbkAct.SaveAs sWbkPthNme & bVrs & kExt, xlOpenXMLWorkbookMacroEnabled
Exit Do
End If
Loop
MsgBox "Version """ & bVrs & """ of workbook: " & _
vbLf & vbLf & Chr(34) & sWbkStd & Chr(34) & " has been created.", _
vbApplicationModal + vbInformation, "Workbook - Save a New Version - Xlsm"
HdeThs:
Call Wbk_Hide(ThisWorkbook)
Exit Sub
NewWbk:
MsgBox "Active Workbook """ & WbkAct.Name & """ has not been saved as yet." & vbLf & _
"A new version cannot be saved!", _
vbApplicationModal + vbCritical, "Workbook - Save New Version - Xlsm"
End Sub
Private Function Fil_FileExist(sFullName As String) As Boolean
Dim sDir As String
Fil_FileExist = (Dir(sFullName) <> Empty)
End Function
Private Sub Wbk_Hide(Wbk As Workbook)
Dim Wnd As Window
For Each Wnd In Wbk.Windows
Wnd.Visible = False
Next
End Sub

Resources