I'm trying to open the most recent file in a folder. In this folder, we have a lot of versions of different files, separated by date and time in the file name.
I can't figure out how to separate by the hour of modification.
The format is like this "Raio X - Grafico - 17.09.2018 07.39.pdf". The only thing that changes is the date and the hour, in the end of the name of the file, every new version.
Dim FileSys, objFile, myFolder, c As Object
Dim Fldname As String
Dim FPath As String
Dim FileN As String
Dim MDataFile As String
Dim Date1 As Date
Dim RDate As String
Dim Hour1 As Date
Dim RHour As String
Date1 = Now()
RDate = Format(Date1, "dd.mm.yyyy")
Hour1 = Time
RHour = Format(Hour1, " hh.mm")
FPath = "R:\TL - Comando de Montagem - Relatorios Internos\Raio X"
FileN = FPath & "\" & "Raio X - Grafico - " & RDate & RHour & ".pdf"
ActivePresentation.FollowHyperlink _
Address:=FileN, _
NewWindow:=True, AddHistory:=True
End Sub
I need to compare the System Hour with the hour of the files in the folder.
Since the positions are at a fixed distance from the end, you can use the Mid and Len functions.
Here's an example:
FileName = "Raio X - Grafico - 17.09.2018 07.39.pdf"
FileHour = Mid(FileName, Len(FileName) - 8, 2)
FileMinute = Mid(FileName, Len(FileName) - 5, 2)
Related
I am trying to rename some pdf files with this kind of name: "2020-01-24-GOOGLE.NY-JPM-XXXXXXXXX.pdf"
into: "2020 01 24 - GOOGLE - JPM - 30p.pdf" with 30p meaning 30 pages (the number of pages in the pdf file).
The structure of the name is always the same, only the letters / numbers change.
I have already prepared some code (that you can find below), yet I am struggling with two things:
How can I "extract" the Broker name, (here JPM)
How can I get the number of pages in the pdf ? I have seen some solutions on the forum requiring Adobe Pro, yet I do not have access to it
Do you have any ideas to solve this problem ?
Here is the code:
Sub FetchName()
Dim nameArray() As Variant
Dim renameArray() As Variant
Dim myPath As String
Dim myFile As String
Dim r As Integer
Dim Year As String
Dim Month As String
Dim Day As String
Dim Company As String
Dim Broker As String
Dim NPage As String
Dim numElements As Integer
Dim s As Integer
Dim t As Integer
Dim AcroDoc As Object
Dim StartNum As Integer
Dim numCar As Integer
'get two inputs
myPath = Worksheets("Cover").Cells(3, 4)
Company = Worksheets("Cover").Cells(3, 2)
'get names in an array
myFile = Dir(myPath & "*.pdf")
r = 1
Do While myFile <> ""
ReDim Preserve nameArray(r)
nameArray(UBound(nameArray)) = myFile
r = r + 1
myFile = Dir
Loop
numElements = UBound(nameArray) - LBound(nameArray) + 1
'prepare array with new names
s = 1
For s = 1 To numElements
Year = Left(nameArray(s), 4)
Month = Mid(nameArray(s), 6, 2)
Day = Mid(nameArray(s), 9, 2)
StartNum = InStr(1, Replace(nameArray(s), "-", "~", 4), "~")
numCar = InStr(1, Replace(nameArray(s), "-", "~", 5), "~") - InStr(1, Replace(nameArray(s), "-", "~", 4), "~") + 1
Broker = Mid(nameArray(s), StartNum, numCar)
'numpage
'ReDim Preserve renameArray(r)
'renameArray(UBound(renameArray)+1) = Year & " " & Month & " " & Day & " - " & Company & " - " & Broker & " - " & NPage & "p"
s = s + 1
Next s
'rename files with renameArray
t = 1
For t = 1 To numElements
Name myPath & nameArray(1) As myPath & renameArray(1)
t = t + 1
Next t
End Sub
enter code here
For the Broker name, you can use InStrRev to search for the position of the last and second last dashes:
namePDF = "2020-01-24-GOOGLE.NY-JPM-XXXXXXXXX.pdf"
lastDashAt = InStrRev(namePDF, "-")
secondLastDashAt = InStrRev(namePDF, "-", lastDashAt - 1)
Broker = Mid(namePDF, secondLastDashAt + 1, lastDashAt - secondLastDashAt - 1)
I have code below to save the current workbook and attach today's date to the end of the file name. How would I modify the code so if two copies of the workbook were to be saved on the same day, the first one would save normally as "Workbook Name, Today's Date.xlsm" and the second one would save as "Workbook Name, Today's Date Copy 2.xlsm". Same thing if the workbook were to be saved 3,4,5 times a day they should save as Copy 3,4,5,etc...
Sub Save_Workbook()
Const Path = "H:\HR\Cole G\Timehseet Test Path\"
Dim FileName As String
Dim Pos As Long
Pos = InStrRev(ActiveWorkbook.Name, ".") - 1
' If there wasn't a ".", then the file doesn't have an extension and Pos = -1
If Dir(Path & Left(ActiveWorkbook.Name, Pos) & Format(Now, "d-mm-yyyy") & Mid(ActiveWorkbook.Name, Pos + 1)) <> "" Then
ActiveWorkbook.SaveAs FileName:=Path & Left(ActiveWorkbook.Name, Pos) & "copy 2" & Mid(ActiveWorkbook.Name, Pos + 1)
Else
ActiveWorkbook.SaveAs FileName:=Path & Left(ActiveWorkbook.Name, Pos) & Format(Now, "d-mm-yyyy") & Mid(ActiveWorkbook.Name, Pos + 1)
End If
End Sub
Instead of appending "Copy xxx", why not to append the time?
eg
"Workbook Name, 2018-04-05 12.30.23.xlsm"
Well, the question could be changed a bit, to get what you are looking for. In general, you are looking for a function, which splits some strings by dots and spaces and increments the last one with 1.
E.g., if this is your input:
"WorkbookName 12.12.12.xlsm"
"WorkbookName 13.18.22 Copy 230.xlsm"
"WorkbookName 12.11.19 Copy 999.xlsm"
Your function should give the folowing output:
"WorkbookName 12.12.12.xlsm"
"WorkbookName 13.18.231.xlsm"
"WorkbookName 12.11.1000.xlsm"
Once you achieve this, the saving of the workbook could be carried out through that function. This is some function that gets that output:
Sub TestMe()
Dim path1 As String: path1 = "WorkbookName 12.12.12.xlsm"
Dim path2 As String: path2 = "WorkbookName 13.18.22 Copy 230.xlsm"
Dim path3 As String: path3 = "WorkbookName 12.11.19 Copy 999.xlsm"
Debug.Print changeName(path1)
Debug.Print changeName(path2)
Debug.Print changeName(path3)
End Sub
Public Function changeName(path As String) As String
changeName = path
Dim varArr As Variant
varArr = Split(path, ".")
Dim splitNumber As Long
splitNumber = UBound(varArr)
Dim preLast As String: preLast = varArr(splitNumber - 1)
If IsNumeric(preLast) Then Exit Function
Dim lastWithSpace As String
lastWithSpace = Split(preLast)(UBound(Split(preLast)))
Dim incrementSome As String
incrementSome = Left(preLast, Len(preLast) - Len(lastWithSpace))
If IsNumeric(lastWithSpace) Then
preLast = Split(preLast)(UBound(Split(preLast))) + 1
varArr(splitNumber - 1) = incrementSome & preLast
changeName = Join(varArr, ".")
End If
End Function
The changeName function could be a bit sanitized, with some checks, whether UBound-1 exists in order to avoid error.The function splits the input string to array by . symbol and works with the pre-last value received. Then, if the value is numeric, it does nothing, but if the value looks like this 22 Copy 230, it splits once again and increments the last element with one.
At the end it returns the string.
If you need to check the date as well, then one more layer of splits and arrays should be added.
Listen, you added a comma after the original name, Great! (now use it)
Dim FileName as String, FileExtension as String
FileName = "Workbook Name, Today's Date Copy 2.xlsm"
Pos = InStrRev(FileName, ".") - 1
FileExtension = ".xlsx" ' <-- Set a default
If Pos > 0 then
FileExtension = Mid(FileName, Pos)
FileName = Left(FileName, Pos)
End if
FileExtension has been pulled out from the FileName, and the Filename doesn't have an extension anymore. Now lets go after the Comma
Pos = InStrRev(FileName, ",")
If Pos2 > 0 then FileName = Left(FileName, Pos2 -1)
That was easy, FileName has now been cleaned of the Date and Copy junk. While you could have looked for the copy before we cleaned it, I think it's easier to just try a few times, since you're going to want to check if the file exists anyway.
You can alternatively just add the time like PhantomLord mentioned.
Dim Try as long
Dim FullName as String
Try = 0
FullName = Path & FileName & Format(Now, ", d-mm-yyyy") & FileExtension
' Lets put a safety limit to stop the code if something goes wrong
Do While Try < 1000 And Dir(FullName) = vbNullString
Try = Try + 1
FullName = Path & FileName & Format(Now, ", d-mm-yyyy") & " Copy " & IIF(Try > 1, Try, vbNullString) & FileExtension
Loop
ActiveWorkbook.SaveAs FileName:=FullName
I even thru in the IIF() for fun!
I have a large number of *.xlsx files in subfolders based on month of the year (e.g., 01, 02, 03) by district. I'd like to loop through each file and append the period associated with the subfolder to the end of each file name. For example, Atlanta 01 Bob Jones.xlsx would become Atlanta 01 Bob Jones 01.xlsx. I have looked at examples on this forum and elsewhere and can't find something similar enough to do what I want. Any help would be greatly appreciated!
This is what I have so far:
Sub DSMReports1()
Dim MM As String
MM = InputBox("Enter Month for reporting in MM format: 01-12", , Range("C6").Value)
Range("C6").Value = MM
Application.DisplayAlerts = False
Dim DistrictDSM As String
Dim Path As String
Dim DistPeriodFileOld As String
Dim DistPeriodFileNew As String
Dim Total As Integer
Dim Period As Integer
DistrictDSM = Range("B3").Value 'Selected from a dropdown list
Path = "H:\Accounting\Monthend 2018\DSM Files\" & DistrictDSM & "\P" & MM & "\"
DistPeriodFileOld = Dir(Path & "*.xlsx")
DistPeriodFileNew = Dir(Path & "*.xlsx") 'This is where I'd like to append the period value found in MM
Do While DistPeriodFileOld <> ""
Name DistPeriodFileOld As DistPeriodFileNew
DistPeriodFileOld = Dir
Loop
Next DistrictDSM
End Sub
If you have a large number of *.xlsx, I believe that this code can help you.
Sub ReadAllFiles(ByVal s As String)
'Remember: Add Reference Microsoft Scripting Runtime
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = ".XLS" Or UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = "XLSX" Then
Debug.Print "readind file " & myFile.Path
End If
Next
End Sub
After, you need to replace old name to new name.
Function RenameFiles(p_file As String) As String
'Atlanta 01 Bob Jones.xlsx
Dim v_name As String
Dim v_extension As String
If UCase(Mid$(p_file, Len(p_file) - 3, 4)) = ".XLS" Then
v_name = Mid$(p_file, 1, Len(p_file) - 4) 'Atlanta 01 Bob Jones
v_extension = Mid$(p_file, Len(p_file) - 2, 4) '.xls
End If
If UCase(Mid$(p_file, Len(p_file) - 3, 4)) = "XLSX" Then
v_name = Mid$(p_file, 1, Len(p_file) - 5) 'Atlanta 01 Bob Jones
v_extension = Mid$(p_file, Len(p_file) - 3, 4) '.xls
End If
RenameFiles = v_name & " 01" & "." & v_extension 'warning --> I fixed 01 here
End Function
Finally:
Sub ReadAllFiles(ByVal s As String)
'Remember: Add Reference Microsoft Scripting Runtime
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = ".XLS" Or UCase(Mid$(myFile.Name, Len(myFile.Name) - 3, 4)) = "XLSX" Then
Debug.Print "reading file " & myFile.Path
FileCopy myFile.Path, RenameFiles(myFile.Path) 'Here we COPY original file to new file
End If
Next
End Sub
I hope I have helped you.
I want to create multiple saves of the same word file using visual basic. each file will need to be named with the day of the month and month name (not numbers) i want this to run from the 1 to 31 on each month. i have a rough code,
Sub Mine()
Dim DateStr, FileStr As String
DateStr = Format$(Date, "DD")
FileStr = DateStr & ".docx"
ActiveDocument.Save
ChangeFileOpenDirectory "Z:\FIR MASTER FOLDER\FCR briefing sheet\2018\Test"
ActiveDocument.SaveAs2 FileName:=FileStr, FileFormat:=wdFormatXMLDocument
End Sub
now how do i add the loop and the day and month format part
try the below. If you want in the format you mention in comment simply put as
Debug.Print monthName & " " & i
Saving to different folders in an amendment to your original question. I am happy to update but this should deal with your initial question as posed.
It works with the current month. You would want a test to make sure doesn't already exist. I tried to show you each of the functions you might consider and how you could structure a loop.
Uses a function from here for end of month.
Sub test()
Dim myDate As Date
Dim myMonth As Long
myDate = Date
Dim monthName As String
monthName = Format$(myDate, "mmmm")
Dim endOfMonth As Long
endOfMonth = CLng(Format$(dhLastDayInMonth(myDate), "dd"))
Dim i As Long
For i = 1 To endOfMonth
Debug.Print monthName & " " & i
Next i
End Sub
Function dhLastDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInMonth = DateSerial(Year(dtmDate), _
Month(dtmDate) + 1, 0)
End Function
So save with the filename you would do something like:
For i = 1 To endOfMonth
ActiveDocument.SaveAs fileName:= "C:\Test\" & monthName & " " & i, FileFormat:=wdFormatXMLDocument
Next i
Reference:
http://www.java2s.com/Code/VBA-Excel-Access-Word/Word/TosaveadocumentwithanewnameusetheSaveAsmethod.htm
Or to create folders for the year:
Sub AddFoldersAndFiles()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
'Dim fso As FileSystemObject ' ''early binding. Requires reference to MS Scripting runtime
'Set fso = New FileSystemObject ''early binding
Dim myYear As Long
Dim endOfMonth As Long
Dim filePathStub As String
filePathStub = "C:\Users\User\Desktop\" ' path to create folders at
myYear = Year(Date)
Dim monthsArray() As Variant
monthsArray = Array("January","February","March","April","May","June","July","August","September","October","November","December")
Dim currentMonth As Long
For currentMonth = LBound(monthsArray) To UBound(monthsArray)
Dim folderName As String
folderName = filePathStub & monthsArray(currentMonth) & CStr(myYear)
folderName = fso.CreateFolder(FolderName)
endOfMonth = CLng(Format$(dhLastDayInMonth(DateSerial(myYear,currentMonth + 1, 0)),"dd"))
Dim currentDay As Long
For currentDay = 1 To endOfMonth
ActiveDocument.SaveAs2 FileName:= folderName & Application.PathSeparator & monthsArray(currentMonth) & " " & currentDay, FileFormat:= wdFormatXMLDocument
Next currentDay
Next currentMonth
End Sub
I'm looking to write a macro to save my current version filename +1 instance of the version. For each new day the version would reset to v01. Ex. Current = DailySheet_20150221v01; Save As = DailySheet_20150221v02; Next Day = DailySheet_20150222v01
While increasing the version number, I am hoping the version won't have to contain the v0 once v10+ has been reached.
I was able to workout how to save the file with today's date:
Sub CopyDailySheet()
Dim datestr As String
datestr = Format(Now, "yyyymmdd")
ActiveWorkbook.SaveAs "D:\Projects\Daily Sheet\DailySheet_" & datestr & ".xlsx"
End Sub
but need additional help in finding the version addition. Could I set the SaveAs to a string, then run it through a For/If - Then set?
Put this out to a couple of my friends and below is their solution:
Sub Copy_DailySheet()
Dim datestr As String, f As String, CurrentFileDate As String, _
CurrentVersion As String, SaveAsDate As String, SaveAsVersion As String
f = ThisWorkbook.FullName
SaveAsDate = Format(Now, "yyyymmdd")
ary = Split(f, "_")
bry = Split(ary(UBound(ary)), "v")
cry = Split(bry(UBound(bry)), ".")
CurrentFileDate = bry(0)
CurrentVersion = cry(0)
SaveAsDate = Format(Now, "yyyymmdd")
If SaveAsDate = CurrentFileDate Then
SaveAsVersion = CurrentVersion + 1
Else
SaveAsVersion = 1
End If
If SaveAsVersion < 10 Then
ThisWorkbook.SaveAs "D:\Projects\Daily Sheet\DailySheet_" & SaveAsDate & "v0" & SaveAsVersion & ".xlsm"
Else
ThisWorkbook.SaveAs "D:\Projects\Daily Sheet\Daily Sheet_" & SaveAsDate & "v" & SaveAsVersion & ".xlsm"
End If
End Sub
Thanks to all those who contributed.
Try this one:
Sub CopyDailySheet()
'Variables declaration
Dim path As String
Dim sht_nm As String
Dim datestr As String
Dim rev As Integer
Dim chk_fil As Boolean
Dim ws As Object
'Variables initialization
path = "D:\Projects\Daily_Sheet"
sht_nm = "DailySheet"
datestr = Format(Now, "yyyymmdd")
rev = 0
'Create new Windows Shell object
Set ws = CreateObject("Wscript.Shell")
'Check the latest existing revision number
Do
rev = rev + 1
chk_fil = ws.Exec("powershell test-path " & path & "\" & sht_nm & "_" & datestr & "v" & Format(rev, "00") & ".*").StdOut.ReadLine
Loop While chk_fil = True
'Save File with new revision number
ActiveWorkbook.SaveAs path & "\" & sht_nm & "_" & datestr & "v" & Format(rev, "00") & ".xlsm"
End Sub
If you have the current filename I would use something like:
Public Function GetNewFileName(s As String) As String
ary = Split(s, "v")
n = "0" & CStr(CLng(ary(1)) + 1)
GetNewFileName = ary(0) & "v" & ary(1)
End Function
Tested with:
Sub MAIN()
strng = GetNewFileName("DailySheet_20150221v02")
MsgBox strng
End Sub