I have three workbooks (Book1,Book2,Book3) all saved as xlsx files. Each day, these workbooks are updated. Assume all workbooks belong to the following directory: C:\Users\abc\Documents\Example which also contains many other files (d,e,f.... etc). I need to check that Book1,Book2,Book3 are updated so that 'Date Modified' = Today's date. If date modified does not equal today's date i need the code to stop running and warn "Incorrect Date". I imagine this task will involve running a for-loop but I am quite new to VBA.
Try:
Sub test()
Dim arrFileNames As Variant
Dim i As Long
Dim strPath As String
Dim strExt As String
arrFileNames = Split("Book1,Book2,Book3", ",")
strPath = "C:\Users\marios.p\Desktop\test" & "\"
strExt = ".xlsx"
Set fs = CreateObject("Scripting.FileSystemObject")
For i = LBound(arrFileNames) To UBound(arrFileNames)
Set f = fs.GetFile(strPath & arrFileNames(i) & strExt)
If f.DateLastModified < Date Then
MsgBox "Incorrect Date"
End If
Next i
End Sub
Related
This is a two part problem that I'm trying to solve. First, I'd like to identify the max date in a column.
If the max date is in the current month, then I'd like to save the file in the current format using the current year and month (filename YYYYMM). If the date is less than the current month, I'd like to save the file with current year and prior month.
This is the code I've started off with to identify the max date but my MsgBox display the time instead of date so I can't confirm if it's actually working.
Dim Max_date As Date
xl.Sheets("Data").Visible = True
xl.Sheets("Data").Select
xl.Range("I:I").Select
Max_date = Application.WorksheetFunction.Max(xl.Range("I:I"))
MsgBox Max_date
please take the time to check the code and configure all you need. Good luck
'This es the configurable part
Sub Export()
Dim filePath As String, fileName As String
filePath = OpenFileExplorer(msoFileDialogFolderPicker) '"" 'define your save path or use -->'OpenFileExplorer(msoFileDialogFolderPicker)
fileName = "eg. 09_03_2021" 'here you code max, remember dont use slash
Copy_Save_Worksheet_As_Workbook "your Sheet to save", fileName, filePath
End Sub
'Starting a procedure to save a worksheet as new workbook
Public Sub Copy_Save_Worksheet_As_Workbook(SheetNameToCopy_ As String, saveAs__ As String, path_ As String)
Application.ScreenUpdating = False
Dim wkb As Workbook
'Check this line too
Const fileExtencion = ".xlsx"
'this is to check if already book open with same name
For Each wkb In Workbooks
If wkb.Name = saveAs__ & fileExtencion Then
Workbooks(wkb.Name).Close False
End If
Next
Dim finalPath As String
finalPath = path_ & "\" & saveAs__
ThisWorkbook.Sheets(SheetNameToCopy_).Select
ActiveSheet.Copy
ActiveSheet.SaveAs fileName:=finalPath & ".xlsx"
Application.ScreenUpdating = True
End Sub
Public Function OpenFileExplorer(t_ As MsoFileDialogType) As String
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(t_)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Where to save"
' Clear out the current filters, and add our own.
.Filters.Clear
If t_ = msoFileDialogFilePicker Then
.Filters.Add "All Files", "*.*"
End If
If .Show = True Then
OpenFileExplorer = .SelectedItems(1)
Else
OpenFileExplorer = ""
End If
End With
End Function
I need to add today's date to a file name.
I have part of the code copied from another file, but it doesn't have that feature.
Where it says "/CARYYMMDD2428395101.BCA" is the place that I need to change to today's date.
Sub Export_Selection_As_Fixed_Length_File()
' Dimension all variables.
Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
Dim sht As Worksheet
'Below are options incase you want to change the folder where VBA stores the .txt file
'We use ActiveWorkbook.Path in this example
'ActiveWorkbook.Path 'the activeworkbook
'ThisWorkbook.Path 'the workbook with the code
'CurDir 'the current directory (when you hit File|open)
'If a cell is blank, what character should be used instead
Filler_Char_To_Replace_Blanks = " "
'Check if the user has made any selection at all
If Selection.Cells.Count < 2 Then
MsgBox "No row has been selected"
Selection.Activate
End
End If
'This is the destination file name.
DestinationFile = ActiveWorkbook.Path & "/CARYYMMDD24284444101.BCA"
'Obtain next free file handle number.
FileNum = FreeFile()
I expect to get the name of the file as CAR19080824284444101.BCA
First I want to point out you qualified your variables incorrectly. The line Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String only declares Filler_Char_To_Replace_Blanks as a String the rest are Variant types.
Format(Date, "yyyymmdd") is what you're looking for you can change the format however, I demonstrate below another way to name, but if you like what I here just modify it.
Sub Export_Selection_As_Fixed_Length_File()
' Dim all variables.
Dim DestinationFile As String, CellValue As String, Filler_Char_To_Replace_Blanks As String
Dim FileNum As Integer, ColumnCount As Integer, RowCountAs Integer, FieldWidth As Integer
Dim sht As Worksheet
'Below are options incase you want to change the folder where VBA stores the .txt file
'We use ActiveWorkbook.Path in this example
'ActiveWorkbook.Path 'the activeworkbook
'ThisWorkbook.Path 'the workbook with the code
'CurDir 'the current directory (when you hit File|open)
'If a cell is blank, what character should be used instead
Filler_Char_To_Replace_Blanks = " "
'Check if the user has made any selection at all
If Selection.Cells.Count < 2 Then
MsgBox "No row has been selected"
Selection.Activate
End
End If
'This is the destination file name. Unsure if you wanted a certain format, but this shows you how to add it.
DestinationFile = ActiveWorkbook.Path & "/CARYYMMDD24284444101.BCA" & Month(Date) &"."&Year(Date)
'Obtain next free file handle number.
FileNum = FreeFile()
This is some pseudo-code, which saves 'ThisWorkbook' into the specified path (directory eg. C:\Test) and adds the date to the end of the filename.
ThisWorkbook.SaveCopyAs <declare_path_variable> & **Format(Date, "dd-mm-yyyy")** & ThisWorkbook.Name
You can do it like this:
'Name of the Excel file with a date/time stamp
XLSFileName = DefPath & "MasterCSV " & _
Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr
I am building a report on Excel that has to be updated monthly. Therefore I get every month a new Excelfile with data that has to be summarized in the report.
The report consists of the calculations of the specific Excelfiles with the data for each month, for example the amount of male or female customers.
Is it possible to create a macro via VBA that creates a path to the new Excelfile so that I do not have to change the path to the file manually? In this case for example instead that I have to change the formula to '...non_activated-2019-03' by typing it in, Excel should do it automatically because there are over 60 of these calculations in which I would have to change the file.
=COUNTIFS('C:\Users\denni\Desktop\Reporting\Non Activated\[non_activated-2019-02.xlsx]non_activated-2019-02'!$M:$M;$B$9;'C:\Users\denni\Desktop\Reporting\Non Activated\[non_activated-2019-02.xlsx]non_activated-2019-02'!$B:$B;$C10)
Yes, it is possible and I do it myself when I need to create reports and log files. Just add the following in your filename String:
filename = "...non_activated-" & Year(Date) & "-" & Month(Date)
Month Number with 0
If you want the month number to start with 0, you can simply change the code like this:
Sub yourSub()
'...
filename = "...non_activated-" & Year(Date) & "-" & getMonthNumber(Date)
'...
End Sub
Function getMonthNumber(data As Date) As String
If Month(data) < 10 Then
getMonthNumber = "0" & Month(data)
Else
getMonthNumber = Month(data)
End If
End Function
Open your file
There're a lot of ways to open (and write on) your file. You can try this:
Open yourPath & yourFilename For Output As #1
Print #1, "Print somenthing on your file"
'Do your stuff
Close #1
Now you have your file saved on your path.
Notes
By using this method, every month it creates automatically a new file which you can easily find.
Just remember to check if the file exists, otherwise it can launch
an exception.
You could use a function like so in a cell, on a sheet, then reference the cell in formulas, then leave them alone.
For example =GetLatestImportFile("C:\workspace\dummy data\")
Function GetLatestImportFile(strPath As String, _
Optional strLookFor As String = "non-activated")
Dim f As Scripting.FileSystemObject
Dim fld As Scripting.Folder
Dim fl As Scripting.File
Dim dt As Date
Set f = New Scripting.FileSystemObject
Set fld = f.GetFolder(strPath)
For Each fl In fld.Files
If InStr(1, fl.Name, strLookFor) > 0 Then
If fl.DateCreated > dt Then
dt = fl.DateCreated
GetLatestImportFile = fl.Name
End If
End If
Next fl
set f=nothing
set fld=nothing
set fl=nothing
End Function
So for now this code is doing quite well and replaces the old reference with the new one!
Sub MySub()
Dim old as String
Dim new as String
Dim i as Integer
old = "activated-2019-01"
new = "activated-2019-02"
For i=4 to 160
Cells(i,"E").FormulaLocal = Replace(Cells(i,"F").FormulaLocal, old, new)
Next i
End Sub
I've written some VBA code using file objects to go into a folder, search for particular files (CSV) that meet certain criteria (contain "HR" in filename and created within specified date range), and copy/paste information out of that file into a master file. The master file is typically a compilation of 250+ workbooks.
The macro works as it should, but it takes about 12 minutes to run, which is a bit excessive. I believe it takes so long to run because it is indexing a folder with 30,000+ files in it.
I've copied the relevant lines of my code below, if anyone is aware of any modifications I could make that would decrease the duration of my macro, I would really appreciate it. I'm relatively new to VBA and coding in general, so I'm learning as I go with these sorts of things! Thanks!
Dim FilePath As String
Dim FileName As String
Dim objFSO As FileSystemObject
Dim objFolder As Folder
Dim objFile As file
Dim fileDate As Date
Dim firstDate As Date
Dim secondDate As Date
'Defining the user-input variables
Worksheets("Sheet1").Activate
firstDate = Cells(2, "E").Value
secondDate = Cells(3, "E").Value
'FilePath to information, defining file objects
FilePath = "\\SRV-1\process\DUMP\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(FilePath)
'Going through Dump folder and finding high resolution files created within the date range
For Each objFile In objFolder.Files
'Checking to see if the file contains the string "HR", indicating high resolution.
If InStr(1, objFile.Name, "HR") Then GoTo Line1 Else GoTo Line3
Line1:
'Storing the file as a variable and checking its creation date
FileName = objFile.Name
OpenFile = FilePath & FileName
fileDate = FileDateTime(OpenFile)
'Checking to see if the file was created between the user input master roll start/end dates
If firstDate < fileDate And secondDate > fileDate Then GoTo Line2 Else GoTo Line3
Line2:
Do stuff: open dump workbook, copy/pase certain range into main workbook, close dump workbook, next objFile
Line3:
Next objFile
This ought to show some improvement, considering the ratio of HR files to total files (250 / 30,000).
Using Dir Function, Minimize reliance on FileSystemObject
The idea here is to use the Dir function first to get a list of all file names that contain the "HR" substring, and only use the FileSystemObject against those files to get the timestamp information -- there's no use incurring the overhead of FSO on every file in that directory.
Then, we process only those files which match the "HR" criteria:
Sub usingDir()
Dim folderPath As String
Dim fileName As String
Dim filesToProcess As New Collection
Dim item As Variant
Dim fileDate As Date
Dim firstDate As Date
Dim secondDate As Date
'Defining the user-input variables
firstDate = Cells(2, "E").Value
secondDate = Cells(3, "E").Value
folderPath = "\\SRV-1\process\DUMP\"
' Gets a collection of files matching the "HR" criteria
fileName = Dir(folderPath)
Do While Not fileName = ""
If InStr(fileName, "HR") > 0 Then
'Only processing files with "HR"
filesToProcess.Add (folderPath & fileName)
End If
fileName = Dir
Loop
'Now we deal only with the "HR" files:
With CreateObject("Scripting.FileSystemObject")
For Each item In filesToProcess
' Check the date last modified
fileDate = .GetFile(item).DateLastModified ' modify as needed
If firstDate < fileDate And secondDate > fileDate Then
'
'
Debug.Print item
'your code to Do Stuff goes here
'
'
'
End If
Next
End With
End Sub
UPDATE: Without Using the FileSystemObject
This was nagging at me, and I figured there must be a way to get the timestamp information without relying on FileSystemObject. There is. We'll still use Dir to traverse the files, but now we'll eliminate any reference to FileSystemObject and replace with some fancy WinAPI function calls. Check out Chip Pearson's article here and download the .bas modules. You'll need the following two files imported to your VBProject:
modGetSetFileTimes
modTimeConversionFunctions
And then you can do something like this:
Option Explicit
Sub withoutFSO()
Dim folderPath As String
Dim FileName As String
Dim filesToProcess As New Collection
Dim item As Variant
Dim fileDate As Date
Dim firstDate As Date
Dim secondDate As Date
'Defining the user-input variables
firstDate = Cells(2, "E").Value
secondDate = Cells(3, "E").Value
folderPath = "\\Your\Path"
' Gets a collection of files matching the "HR" criteria and our Date range
FileName = Dir(folderPath)
Do While Not FileName = ""
'Only processing files with "HR"
If InStr(FileName, "HR") > 0 Then
' Only process files that meet our date criteria
fileDate = CDate(modGetSetFileTimes.GetFileDateTime(CStr(item), FileDateLastModified))
If firstDate < fileDate And secondDate > fileDate Then
filesToProcess.Add (folderPath & FileName)
End If
End If
FileName = Dir
Loop
'Now we deal only with the matching files:
For Each item In filesToProcess
Debug.Print item
Debug.Print fileDate
'your code to Do Stuff goes here
'
'
'
Next
End Sub
This should be an improvement even over my original answer, and, if combined with a more efficient manner of retrieving data (i.e., using ADO instead of Workbooks.Open, if possible) then you should be very optimized.
Take a look at Power Query -- it's a Microsoft add-in for Excel versions 2012 & 2013, and built-in to 2016. Setting up PQ to do this will be amazingly fast, and the 'script' is reusable! No VBA needed.
You can search and combine the multiple files on the specified criteria, but then merge or append to the new/master file, too. For efficiency, rather than processing each file individually, might I suggest gathering up all the data files (by your criteria), combining them to one table, then use the new table to merge/append to the new/master
Hope this helps...
In addition to using the Dir function instead of FileSystemObject, if you cannot automate PowerQuery, and all you need is the data and not the formatting, consider making a direct data connection to the source workbooks using ADODB.
Add a reference to Microsoft ActiveX Data Objects 6.1 Library (via Tools -> References...). There may be versions other than 6.1; choose the highest.
Then you can use something like the following code:
Dim fso As New Scripting.FileSystemObject
Dim filepath As Variant
For Each filepath In filesToProcess
' Check the date last modified
fileDate = fso.GetFile(item).DateLastModified ' modify as needed
If firstDate < fileDate And secondDate > fileDate Then
Dim connectionString As String
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
Dim worksheetName As String
worksheetName = "Sheet1"
' There can be multiple worksheets per workbook.
' If you are only interested in one worksheet per workbook, then fill in worksheetName somehow
' Otherwise, you will probably need an inner loop to iterate over all the worksheets
Dim sql As String
sql = _
"SELECT * " & _
"FROM [" & worksheetName & "$]"
Dim rs As New ADODB.Recordset
rs.Open sql, connectionString
destinationWorksheet.Range("A1").CopyFromRecordset rs
rs.Close
Set rs = Nothing
End If
Next
It took a long time because for each interation you pass the information to the main worksheet.
In this case is better use a multidimensional array to keep the information and in the end of the process you pass the the array info in the main worksheet.
I dont know what information you get in each worksheet, soo i cant create an didatical example for you.
Forgive me if this is an easy problem, Im still learning..
I have an excel file, that takes data and performs analytics to compose graphs. right now method to update is manual copying and pasting from 2 other data sources. I can easily create a macro to import the first source as the data location/file name is always the same. The second source is trickier, as the file has some standardized naming convention, but a date is added, as it is refreshed once a week, every Monday or tuesday. is there a way to automate pulling the data from the external source (sharepoint library) and telling it to find the most current version? either by understanding the date convention added in the file name, or by another means of modified date or other criteria? the file is kept with previous archived copies. I do not own the report, sharepoint site, or library it is kept in, so I cant influence those factors :(. any help appreciated, and I can provide better details and explanation.
There are two basic approaches that I know of, either allow the user to choose the file through a dialog box, or use the "Dir" function to find the file with the most recent date.
First approach (code I use frequently):
Public Function ChooseOpenFile() As String
Dim strSlash As String
If InStr(1, ActiveWorkbook.Path, "/") > 0 Then
strSlash = "/"
Else
strSlash = "\"
End If
With Application.FileDialog(msoFileDialogOpen)
.Title = "Select the first file to open in series:"
.InitialFileName = Replace(ActiveWorkbook.Path, "http:", "", 1) & strSlash
Call .Filters.Clear
Call .Filters.Add("Excel Files Only", "*.xls, *.xlsx, *.xlsb")
'only allow the user to select one file
.AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = .Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
ChooseOpenFile = .SelectedItems(1)
End If
End With
End Function
As for the second approach, as long as you can already access the folder programmatically, you build a loop to cycle through the files, extract the date from each file, test for being more recent than previous versions and store the filename of the most recent version to pass out of the loop.
Function MostRecentFile() As String
Dim dateTest As Date
Dim dateRecent As Date
Dim strMyFile As String
Dim strMyFolder As String
Dim strCurrentFile As String
Dim strSlash As String
strMyFolder = ThisWorkbook.Path
If InStr(1, strMyFolder, "/") > 0 Then
strSlash = "/"
Else
strSlash = "\"
End If
strMyFile = Dir(Replace(strMyFolder, "http:", "") & strSlash & "*.xls*")
Do While strMyFile <> ""
'Modify this line (number of characters and extension to replace) as needed.
dateTest = CDate(Replace(Right(strMyFile, 15), ".xls*", ""))
If dateTest > dateRecent Then
dateRecent = dateTest
strCurrentFile = strMyFile
End If
Stop
Dir
Loop
MostRecentFile = strCurrentFile
End Function
You can browse to the file.
Sub GetOpenFile()
Dim fileStr As String
fileStr = Application.GetOpenFilename()
If fileStr = "False" Then Exit Sub
Workbooks.Open fileStr
End Sub
If you want some kind of automated solution, based on your system date, like the next Monday ot Tuesday, you can get the machine to figure it out, and pass the result to the appropriate string in the file path.
Sub NameAsNextMon()
Dim K As Integer
Dim dteMon As Date
Dim tempName As Variant
K = Weekday(Now)
dteMon = Now() + (9 - K)
tempName = Year(dteMon) & "-" & Month(dteMon) & "-" & Day(dteMon) & ".xls"
Do
fName = Application.GetSaveAsFilename(tempName)
Loop Until fName <> False
ActiveWorkbook.SaveAs Filename:=fName
End Sub