The below mentioned VBA code works perfectly when i run it on Local Hard disk however when i run and move files saved on google drive and if number of files are more than 50 it shows runtime error (only on Google Drive) can someone help.
Run-time Error 75:
Path/file Access error
Below mentioned is the code
Sub moveAllFilesInDateFolder()
Dim DateFold As String, fileName As String
Const sFolderPath As String = "G:\My Drive\Source"
Const dFolderPath As String = "G:\My Drive\Destination\07102022"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
Do While fileName <> ""
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
fileName = Dir
Loop
End Sub
I have this code on the OnClick_Event of a button on a form to Create a folder on my pc.
On Error Resume Next
Dim fs, cf, strFolder
Dim FolderName As String
FolderName = DLookup("F_SNr", "tblFahrzeug", "F_SNr = '" & Me.F_SNr.Value & "'")
strFolder = "C:\Users\IQeov95\Desktop\All Data\" & FolderName & ""
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(strFolder) = True Then
MsgBox "'" & strFolder & "' already exists!"
Else
Set cf = fs.CreateFolder(strFolder)
If fs.FolderExists(strFolder) = True Then
MsgBox "'" & strFolder & "' successfully created!"
Else
MsgBox "'" & strFolder & "' was not created successfully!"
End If
End If
The code works just fine as long as the path is on my pc. How does the "strFolder" variable has to look like to create the folder on my SharePoint? I've tryed entering the SharePoint link but that didnt work. Also i tryed using the MkDir command but got the Run Time Error 76: Path not found.
Thanks for any help in advance!
I'm trying to create a list of files in a specific directory folder where I am renaming the files, but because there is a chance some files should not be renamed, I only need to rename the PDF files that begin with the letters "AB".
The renaming works fine, I just need to make sure it only renames specific files.
Private Sub CMD_RENAME_FILES_Click()
On Error GoTo CMD_RENAME_FILES_ERR
Dim varDir As String
varDir = Me.TXT_BILLING_STATEMENT_PATH
If MsgBox("Are you sure you want to rename all of the files in the directory " & "'" & varDir & "'", vbYesNo, "Confirm") = vbNo Then
Exit Sub
Else
Dim strFileName, varDateString As String
Dim strFolder As String: strFolder = Nz(Me.TXT_BILLING_STATEMENT_PATH, "Z:\")
Dim strFileSpec As String: strFileSpec = strFolder & "*.pdf"
Dim FileList() As String
Dim intFoundFiles As Integer
DoCmd.RunSQL ("UPDATE tblDirFileList SET tblDirFileList.RenameSelection = -1 WHERE FileName LIKE 'AB*'")
strFileName = Dir(strFileSpec, "AB*.PDF") 'THIS AB* DOESN'T WORK"
varDateString = Format(Date, "mmddyy")
Do While Len(strFileName) > 0
ReDim Preserve FileList(intFoundFiles)
FileList(intFoundFiles) = strFileName
intFoundFiles = intFoundFiles + 1
varLoanNumString = Mid(strFileName, 4, 9)
varNewStrFile = varLoanNumString & " - BILL STMT - " & varDateString & ".pdf"
On Error Resume Next
Name strFolder & strFileName As strFolder & varNewStrFile
strFileName = Dir
Loop
Call CMD_GET_FILE_NAMES_Click
End If
CMD_RENAME_FILES_ERR_EXIT:
Exit Sub
CMD_RENAME_FILES_ERR:
Call LogError(Err.Number, Err.Description, "CMD_RENAME_FILES_Click()")
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Resume CMD_RENAME_FILES_ERR_EXIT
End Sub
Background:
Several years ago, I made a spreadsheet to generate a list of samples to be tested each day. The user (usually me) checks boxes to indicate which tests' samples to list. Then the "save load sheet" button uses VBA to requery a database connection for sample information, populates the formatted list through a complex series of formulas, copies the values from the formula sheet ("Generator") to another sheet ("LoadSheet"), copies that sheet to a new workbook, and saves it with the date as filename in a folder according to year and month.
It worked pretty dependably for about 5 years, right up until a couple of weeks ago when my computer was upgraded from Windows 7 with Office 2013 to Windows 10 with Office 2016.
Problem:
Now, when I try to execute the code, I get Runtime error '1004: Copy method of Worksheet class failed."
Sub SaveAs()
'Copy to new workbook.
Sheets("LoadSheet").Copy '<---This is the line that fails.
' Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
'Save.
'If the worksheet already exists, the user will be asked whether to replace the file or not.
'If it already exists and is currently open, an error could arise.
'Hopefully that won't come up before I have time to think of a way to implement error handling.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Range("A1").Select
Sheets(1).Select
Range("A1").Select
ActiveWorkbook.Save
Application.CutCopyMode = False
ThisWorkbook.Activate
Workbooks(Format(Now, "mm-dd-yy") & "x.xlsx").Activate
End Sub
This is the code that saves the file. It fails on the line indicated.
What I've already tried:
I've tried right-clicking on the worksheet tab, clicking "Move or Copy..." and try to create a copy in a new workbook. Nothing happens. No error message, no new worksheet/book, nothing.
Same thing happens if I try to "move" rather than "copy."
If I try right-clicking and creating a copy in the same workbook, I get a new blank sheet, rather than a copy.
I tried repairing my Office installation, but that didn't help.
I read about some cases where users suspected file corruption, so I even tried manually copying the contents to a new workbook by Ctrl+A,C,V one sheet at a time, and then doing the same for the code. No effect.
I tried Sheets(Worksheets.Count).Select followed by ActiveSheet.Copy, since the sheet is the last one in the book, but of course that didn't work.
I read that it could be because the workbook needed to be saved first, so I tried ActiveWorkbook.Save before the copy. Still the same result.
I tried decompiling/recompiling the worksheet to no effect.
It worked fine on Windows 7 with Office 2013 (and still does on a co-worker's Win7/Excel2013 machine), but I couldn't find anything online about problems with the Sheets.Copy method in Excel 2016, so I don't know if either of those is relevant.
Any ideas?
EDIT: I've tried it on an identical computer (also running Windows 10 & Office 2016) and had the same result. I'm not sure how commonly an installation becomes corrupted, but this feels like more than coincidence. The other computer is rarely used by anyone, and it's being used primarily to run an instance of SQL Server Express and a Windows service I wrote, so I suspect that makes corruption even less likely.
I've got a workaround for now... I just save the file with the filename and path I would have used for the copy, then do a For Each on each worksheet, deleting anything not named "LoadSheet."
Sub SaveAs()
On Error GoTo SaveAs_Err
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
' Turn off alerts. They're annoying. I don't care if it's poor form, I just want to be done with this. I'm not being paid to write code.
Application.DisplayAlerts = False
'Save, disregarding consequences.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Remove extraneous sheets.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "LoadSheet" Then ws.Delete
Next
Application.DisplayAlerts = True
Exit Sub
SaveAs_Err:
Application.DisplayAlerts = True
MsgBox ("An error occurred while saving the file.")
Debug.Print "Error " & Err.Number & ": " & Err.Description
End Sub
I'm still interested in fixing the root cause of this problem, so if anyone has ideas, I'm all ears! I'll probably still try the uninstall/reinstall, but I don't expect it to change anything.
Brute force fix, try:
Sub SaveAs()
Dim newWB as Workbook, i as Integer, copyRange as Range, fName as String
Set newWB = Workbooks.Add
While newWB.Worksheets.Count > 1
newWB.Worksheets(newWB.Worksheets.Count).Delete
Wend
newWB.Worksheets(1).Name = "LoadSheet"
' get a handle on the sheet's usedRange object
Set copyRange = ThisWorkbook.Worksheets("LoadSheet").UsedRange
' assign the values to the newWB.Worksheets(1)
'newWB.Worksheets(1).Range(copyRange.Address).Value = copyRange.Value
copyRange.Copy Destination:=newWB.Worksheets(1).Range(copyRange.Address)
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
newWB.SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks.Open(fName)
End Sub
Alternatively, use the SaveAs method of the Worksheets class:
Sub SaveAs()
Dim fName as String
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
ThisWorkbook.Worksheets("LoadSheet").SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Save
Application.CutCopyMode = False
Workbooks.Open(fName)
End Sub
I've also revised both solutions to avoid the potential error you comment:
If it already exists and is currently open, an error could arise.
I would work with your IT and/or MS support on the specific failure of the .Copy method, though, it's almost certainly a problem with your installation and may result in nastier errors in the future.
I have a Sub within my application that is currently located within a userform called FRMPFC_folderCreatorWindow. For clarity of the overall application I wish to move this Sub from the userform into a Module called PFC_filesystemManipulation and call the Sub from there via a button in FRMPFC_folderCreatorWindow however, when I do this and run my code, an error is generated at the line:
For Each cCont In Me.Controls
I understand that this is because the Sub has been taken outside of the context of the form however, how do I maintain context without using Me.Controls? I'm guessing I need to reference the form and use FRMPFC_folderCreatorWindow.Controls but as most of the controls are nested within frames I'm unsure whether my current code acts upon the form or just the frame within which the button is located. Any help would be much appreciated.
Private Sub PFC_createFolders(Basepath, currentControl, parentFolder, parentGroup)
Dim cCont As Control
Dim createSubFolder As String
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
'Check if the project folder already exists and if so, raise an error and exit
MkDir Basepath & "\" & parentFolder
'Create the superceded documents folder in every 2nd generation folder
MkDir Basepath & "\" & parentFolder & "\" & "_Old versions"
For Each cCont In Me.Controls
If TypeName(cCont) = "CheckBox" Then
If cCont.GroupName = parentGroup Then
If cCont.Value = True Then
If cCont.Name <> currentControl Then
createSubFolder = cCont.Caption
NewFolder = Basepath & "\" & parentFolder & "\" & createSubFolder
If fs.folderexists(NewFolder) Then
'do nothing
Else
'Create 3rd generation folder
MkDir NewFolder
'Create the superceded documents folder in every 3rd generation folder
MkDir NewFolder & "\" & "_Old versions"
'Create hard-coded subfolders within Confirmit Exports
If createSubFolder = "Confirmit Exports" Then
MkDir Basepath & "\" & parentFolder & "\" & createSubFolder & "\Triple S"
MkDir Basepath & "\" & parentFolder & "\" & createSubFolder & "\Word Export"
MkDir Basepath & "\" & parentFolder & "\" & createSubFolder & "\Survey Definition"
MkDir Basepath & "\" & parentFolder & "\" & createSubFolder & "\Data"
MkDir Basepath & "\" & parentFolder & "\" & createSubFolder & "\Data" & "\" & "Early Data"
MkDir Basepath & "\" & parentFolder & "\" & createSubFolder & "\Data" & "\" & "Final Data"
End If
End If
End If
End If
End If
End If
Next cCont
End Sub
I've just experimented with this and replacing the Me.Controls with the following code works:
FRMPFC_folderCreatorWindow.Controls