I have a folder on sharepoint/onedrive business that contains Excel files. These files are produced daily by system and named by that date.
22.05.2021.xlsx
21.05.2021.xlsx
20.05.2021.xlsx
I am trying VBA script that can detect what is latest date that the system creates in this folder.
Sub Latest_file_in_range()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For x = Now() To (Now() - 15) Step -1
Workbooks.Open Filename:="https://***-my.sharepoint.com/***/" & Format(x, "dd.mm.yyyy") & ".xlsx", UpdateLinks:=xlUpdateLinksNever
If Err = 0 Then
MsgBox x
Exit For
End If
Next
End Sub
Basically, I try to run a for loop backward from today and to exit at any loop that file is detected. This does not work. The script opens all files in the folder without stopping at the first file.
i.e. my expected result is that MsgBox shows latest file:
22.05.2021.xlsx
Please help me with this, great thanks.
As Rory wrote in the comments, your problem is that if the first file cannot be found (that's the one with the date of today), the err-object is set to an error (1004). Once the error is set, it stays there unless another error occurs that set it to the new error number. Opening a file successfully does not set the err to 0.
Two ways to handle that. A) Reset the error manually using Clear.
For x = Now() To (Now() - 15) Step -1
Workbooks.Open Filename:="https://***-my.sharepoint.com/***/" & Format(x, "dd.mm.yyyy") & ".xlsx", UpdateLinks:=xlUpdateLinksNever
If Err = 0 Then
MsgBox x
Exit For
End If
Err.Clear
Next
B) Write the result of the open-Command into a variable and check if it is set:
For x = Now() To (Now() - 15) Step -1
Dim wb as Workbook
Set wb = Workbooks.Open("https://***-my.sharepoint.com/***/" & Format(x, "dd.mm.yyyy") & ".xlsx", UpdateLinks:=xlUpdateLinksNever)
If Not wb Is Nothing Then
MsgBox x
Exit For
End If
Next
Related
So i have 2 workbooks that contains the same code because I have to check the code with somebody else.
But the thing is, on the back-up workbook everything is working just fine, but on the main one, I have a "Run-time error -2147467259(80004005): automation error - unspecified error when it comes to this piece of code If wb1.BuiltinDocumentProperties("Last Save Time") > wb2.BuiltinDocumentProperties("Last Save Time") Then
Does anybody knows what could go wrong ? When I use the watch windows, i can see that "wb1" properties are not taken into accounts, but for the "wb2" it works
full sub :
Sub Fyle()
Set fd = Application.FileDialog(msoFileDialogFilePicker)
MsgBox ("Please choose 2 files to comparer.")
check = 0
While check <> 2
With fd
.InitialFileName = FPath
.AllowMultiSelect = True
.Show
End With
check = fd.SelectedItems.Count
If check <> 2 Then MsgBox ("please choose only 2 files")
Wend
Set wb1 = Workbooks.Open(fd.SelectedItems(1))
Set wb2 = Workbooks.Open(fd.SelectedItems(2))
If wb1.BuiltinDocumentProperties("Last Save Time") > wb2.BuiltinDocumentProperties("Last Save Time") Then
Call order(wb2, wb1)
MsgBox ("Vous allez comparer " & wb2.name & " avec " & wb1.name)
Else
Call order(wb1, wb2)
MsgBox ("Vous allez comparer " & wb1.name & " avec " & wb2.name)
End If
wb1.Close False
wb2.Close False
End Sub
i tried to copy and paste the whole code (many subs being called from different modules) from the back-up workbook to the main, but the error remains here.
I am working on making a universal production time sheet(wbTime) for each dept that will work across all shifts and lines. I have where all the necessary information is required to be entered, all the data getting copied into a table in another workbook(wbLog) and saved to be able to do analysis on the production data.
However, when it gets to trying to save the actual time sheet in the proper folder according to shift and machine line I start running into problems. I have it pulling part of the path from certain cells and the filename form the date the enter. It is getting to the last line and throwing a run-time error 1004 "Method 'SaveAs' of object_Worbook'failed".
I have only been playing with vba for 2 months so it is probably something small that I just do not see...
Sub TransferData()
If ActiveSheet.Range("E2").Value = "" Then
MsgBox "Operator Name Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("H2").Value = "" Then
MsgBox "Date Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("K2").Value = "" Then
MsgBox "Shift Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
If ActiveSheet.Range("M2").Value = "" Then
MsgBox "Line Required", vbInformation, "ALERT: Missing Information"
Cancel = True
Exit Sub
End If
Dim wbTime As Workbook
Set wbTime = ThisWorkbook
Dim wbData As Workbook
Dim LastRow As Long
Set wbTime = ActiveWorkbook
With wbTime.Sheets("Production Time Sheet")
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
End With
wbTime.Sheets("Production Time Sheet").Range("A6:R" & LastRow).Copy
Set wbData = Workbooks.Open("S:\Lean Carrollton Initiative\Michael\Time Sheet Data LT Test.xlsm")
Set wbData = ActiveWorkbook
wbData.Worksheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
wbData.Close SaveChanges:=True
Dim Fname As String
Dim Path As String
Dim shft As String
Dim Line As String
Set wbTime = ActiveWorkbook
Fname = Sheets("Production Time Sheet").Range("I2").Text
shft = Sheets("Production Time Sheet").Range("Z9").Text
Line = Sheets("Production Time Sheet").Range("AC11").Text
Path = "K:\Groups\OFS Time Sheets\8hr Production Schedule\LT Jacketing\" & shft & Line & Fname & ".xlsx"
ActiveWorkbook.SaveAs filename:=Path, FileFormat:=xlNormal
End Sub
You are using as name of file the text 2/5/2019.xlsx. As far as I know, the simbol / cannot be used in Windows to name a file.
Try with a different name for file. Something like:
Fname = Replace(Sheets("Production Time Sheet").Range("I2").Text,"/","-")
a) Don't use Range.Text, use Range.Value2.
Text will give you exactly what is written in the cell, and if the cell diplays ###because your cell is to narrow to display a number, it will give you ###.
b) Put a statement Debug.print path before the SaveAs and check in the immediate window (Ctrl+G) if the path is exactly what you expect.
c) Be sure that when you issue the SaveAs-command, the same file is not already open in Excel - this happens often when you test your code repeatedly (it may still open from the last test). SaveAs saves a copy of the file and keeps it open!
d) Use FileFormat:=xlOpenXMLWorkbook when you name the file with extension xlsx. xlNormal will save the file with the old Excel file format and expects xls as extension.
e) Try to save the file with exactly the name from the Excel SaveAs dialog to see if the filename is okay and you have permission to save a file.
There are a number of issues with this error, but none seem to match my case exactly so posting in the hope of some help.
I have a macro which takes all the files in a directory, opens them silently in a new (hidden) instance of Excel and does two "Save As" operations: one to a location on SharePoint and one to an archive folder. The purpose of this is that the files are produced by SAS in XML format with an XLS extension. Saving them as native XLSX reduces file size dramatically.
Each day we produce a number of files which we then run the macro on. It has been erroring on the same file each day; that is to say it's not exactly the same file, but the same report with different versions each day. It is the largest of the files, but other than that there's nothing outstanding about it.
There are two other oddities:
When running the code step-by-step with F8, the error doesn't occur - this has meant I've been unable to pinpoint exactly where it's erroring;
The code has an option to skip files that error - when skipping and rerunning it again immediately afterwards, with no other changes, the error doesn't occur the second time.
Here's the code; the macro is called different times with different locations as parameters:
Sub LoopThroughDirectory(inPath As String, sharepointPath As String, archivePath As String)
Dim sDir As String
Dim app As New Excel.Application
Dim wb As Excel.Workbook
Dim mbErr As Integer, mbFinished As Integer
If Right(inPath, 1) <> "\" Then inPath = inPath & "\"
On Error GoTo ErrHandler:
sDir = Dir$(inPath, vbNormal)
Do Until Len(sDir) = 0
On Error GoTo LoopError:
app.Visible = False
app.DisplayAlerts = False
Set wb = app.Workbooks.Add(inPath & sDir)
With wb
.SaveAs Filename:=sharepointPath & Left(.Name, InStrRev(.Name, ".")) & "xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, ReadOnlyRecommended:=True
.SaveAs Filename:=archivePath & Left(.Name, InStrRev(.Name, ".")) & "xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
Set wb = Nothing
app.DisplayAlerts = True
app.Quit
Kill (inPath & sDir) ' delete the file
NextFile:
sDir = Dir$ ' find the next filename
Loop
mbFinished = MsgBox( _
"The process has finished. You may need to review any files that have errored.", _
vbOKOnly, _
"Process finished" _
)
On Error GoTo 0
Exit Sub
ErrHandler:
mbErr = MsgBox( _
"There has been an error finding files. Check the SharePoint folder and try again.", _
vbCritical + vbOKOnly, _
"Error finding files" _
)
On Error GoTo 0
Exit Sub
LoopError:
Select Case MsgBox("There has been an error with " & sDir & "." & vbCrLf & vbCrLf & _
"The error is " & vbCrLf & vbCrLf & _
Err.Description & "." & vbCrLf & vbCrLf & _
"Press OK to continue with the next file or Cancel to stop the process.", _
vbCritical + vbOKCancel, "Error")
Case vbOK
Resume NextFile ' go back and try the next file
Case vbCancel
On Error GoTo 0
Exit Sub ' stop processing the files
End Select
End Sub
I suggest to insert the sub below underneath your existing code, outside your procedure but in the same code module.
Private Sub WaitASecond(ByVal Sec As Single)
Dim WaitTill As Single
WaitTill = Timer + Sec
Do
DoEvents
Loop While Timer < WaitTill
End Sub
Call it from your main procedure with a line of code like this.
WaitASecond(0.5) ' which would wait for half a second
Experiment with both the length of time, in increments of 0.25 seconds, if you like, and the location of the code. Bear in mind that it seems that your biggest file creates the problem. So, you might limit the call to that one file or vary the length of the wait depending upon the file size (if it makes a significant difference to your process).
You might instroduce a wait after each SaveAs, only after both SaveAs and/or after the Kill.
I am trying to loop through all files in a folder, open them and remove document info. I am having trouble dealing with files that cannot be opened or when opened have a pop us regarding disabling macros. I tried to solve this using on error resume next and on error goto 0. But then I get a runtime failure because my workbook object (wb) has not been set when I was trying to close files that did open.
I have read the documentation on "On Error Resume Next" & "On error goto 0" but I do not believe I am using them correctly here.
Any help is greatly appreciated, Thanks.
Option Explicit
Sub test_Scrubber_New()
Dim directory As String, fileName As String, i As Variant, wb As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'directory = "C:\Users\bayli\Desktop\Files for Testing\"
directory = "C:\Users\bayli\Desktop\excel files\"
fileName = Dir(directory & "*.xl??")
i = 0
Do While fileName <> ""
On Error Resume Next
Set wb = Workbooks.Open(directory & fileName)
On Error GoTo 0
'remove info
ActiveWorkbook.RemoveDocumentInformation (xlRDIAll)
wb.Close True
i = i + 1
fileName = Dir()
Application.StatusBar = "Files Completed: " & i
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Complete"
End Sub
I updated my code to include: If Not wb Is Nothing Then remove the info as #PatricK suggested and it is working however it keeps stopping with a pop up about updating links. If I click "Do not update" my code continues working as needed but is there a way to handle this problem. I am looping through over 5k files so as you can imagine it is taking a while. The time it is taking is not a problem but currently I am sitting here having to click "dont update" quite a few times. I thought Application.DisplayAlerts = False would prevent these pop ups however it is not.
OK, so there are a couple questions here. First, regarding the error handling. When you're using inline error handling (On Error Resume Next), the basic pattern is to turn off the automatic error handling, run the line of code that you want to "catch" the error for, then test to see if the Err.Number is zero:
On Error Resume Next
ProcedureThatCanError
If Err.Number <> 0 Then
'handle it.
End If
On Error GoTo 0
The rest of the questions deal with dialogs you can encounter when you're opening workbooks. Most of this is documented on the MSDN page for Workbook.Open, but you'll want to change the Application.AutomationSecurity property to deal with the macro prompts as appropriate. For the updates, you should pass the appropriate UpdateLinks parameter. I'd also recommend specifying IgnoreReadOnlyRecommended, Notify, and CorruptLoad. Something like this should work (untested), or at least get you a lot closer:
Sub TestScrubberNew() 'Underscores should be avoided in method names.
Dim directory As String, fileName As String, i As Variant, wb As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim security As MsoAutomationSecurity
security = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
directory = "C:\Users\bayli\Desktop\excel files\"
fileName = Dir(directory & "*.xl??")
i = 0
Do While fileName <> vbNullString
On Error Resume Next
Set wb = Workbooks.Open(fileName:=directory & fileName, _
UpdateLinks:=0, _
IgnoreReadOnlyRecommended:=True, _
Notify:=False, _
CorruptLoad:=xlNormalLoad)
If Err.Number = 0 And Not wb Is Nothing Then
On Error GoTo 0
wb.RemoveDocumentInformation xlRDIAll
wb.Close True
i = i + 1
Application.StatusBar = "Files Completed: " & i
fileName = Dir()
Else
Err.Clear
On Error GoTo 0
'Handle (maybe log?) file that didn't open.
End If
Loop
Application.AutomationSecurity = security
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Complete"
End Sub
I have tried to collect all codes I could have done and it still not work for me.
What I want to do is to Schedule Task of my Excel file and I have code "RunExcel.vbs" as attached but still not working.
Reference Link: How to set recurring schedule for xlsm file using Windows Task Scheduler
Reference Link: https://www.mrexcel.com/forum/excel-questions/794869-vb-script-refresh-bloomberg-feed-excel.html
Open file “PriceRealTIme.xlsm”(Macro-enabled workbook) which is inside “TEst folder”.
Ignore to update link
Let it “Refresh Bloomberg Data” and “wait for at 1 minutes or until it done refreshing”.
Once it’s done. I want to copy paste Value of those columns by using Macro named “CopyPaste”.
Finally, let it “Save” and “Close” file.
' a .vbs file is just a text file containing visual basic code that has the extension renamed from .txt to .vbs
'Write Excel.xls Sheet's full path here
strPath = "C:\Users\chaic\OneDrive\Desktop\TEst\PriceRealTIme.xlsm"
'Write the macro name - could try including module name
strMacro = "Sheet1.CopyPaste"
'Create an Excel instance and set visibility of the instance
Set objApp = CreateObject("Excel.Application")
objApp.Visible = True ' or False
'Open workbook; Run Bloomberg Addin; Run Macro; Save Workbook with changes; Close; Quit Excel
Set wbToRun = objApp.Workbooks.Open(strPath)
Private Const BRG_ADDIN As String = "BloombergUI.xla"
Private Const BRG_REFRESH As String = "!RefreshAllStaticData"
Private TimePassed As Integer
Sub StartAutomation()
Dim oAddin As Workbook
On Error Resume Next
Set oAddin = Workbooks(BRG_ADDIN)
On Error GoTo 0
If Not oAddin Is Nothing Then
Application.Run BRG_ADDIN & BRG_REFRESH
StartTimer
End If
End Sub
Private Sub StartTimer()
TimePassed = 10
WaitTillUpdateComplete
End Sub
Sub WaitTillUpdateComplete()
If WorksheetFunction.CountIf(ThisWorkbook.Names("BloombergDataRange").RefersToRange,"#VALUE!") = 0 Then
Application.StatusBar = "Data update used " & TimePassed & "seconds, automation started at " & Now
Else
Application.StatusBar = "Waiting for Bloomberg Data to finish updating (" & TimePassed & " seconds)..."
TimePassed = TimePassed + 1
Application.OnTime Now + TimeSerial(0, 0, 1), "WaitTillUpdateComplete"
End If
End Sub
objApp.Run strMacro ' wbToRun.Name & "!" & strMacro
wbToRun.Save
wbToRun.Close
objApp.Quit
'Leaves an onscreen message!
MsgBox strPath & " " & strMacro & " macro and .vbs successfully completed!", vbInformation
This is an old threat, but maybe this answer will help others.
The code below is working for me. The computer is set for it to never sleep or lock the screen.
The computer is using Office 365 and excel 2016.
' a .vbs file is just a text file containing visual basic code that has the extension renamed from .txt to .vbs
'Write Excel.xls Sheet's full path here
strPath = "myPath"
'Create an Excel instance and set visibility of the instance
Set objApp = CreateObject("Excel.Application")
objApp.Visible = False ' or True
Set wbToRun = objApp.Workbooks.Open(strPath)
StartAutomation
Sub StartAutomation()
Dim oAddin
Set oAddin = objApp.Workbooks.Open("C:\blp\API\Office Tools\BloombergUI.xla")
objApp.Addins("Bloomberg Excel Tools").Installed = False
objApp.Addins("Bloomberg Excel Tools").Installed = True
If Not oAddin Is Nothing Then
objApp.DisplayAlerts = False
objApp.Calculate
objApp.Run "RefreshAllStaticData"
objApp.Calculate
objApp.Run "RefreshAllStaticData"
WaitTillUpdateComplete
End If
End Sub
Dim t
t = 0
Private Sub WaitTillUpdateComplete()
objApp.Calculate
If objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#NAME?") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A Requesting Data...") > 0 Then
If t < 5 Then
t = t+ 1
waitlonger
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub
Sub waitlonger()
Dim x
x = Now + TimeValue("00:00:40")
Do While x > Now
Loop
objApp.Calculate
End Sub
wbToRun.Save
wbToRun.Close
objApp.DisplayAlerts = False
objApp.Quit