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
Related
I have two workbooks one "database" and another "source". What I'm trying to achieve is to set up a loop that would iterate thru a known range in "source" wb and create links in "database". Data in the "source" wb = C7:C38.
Any ideas?
Code below is the one i'm using to pull single values for the links - how can I make it loop thru range C7:C38?
Option Explicit
'**********Using ip address to link/locate folders in the the directory.
Public Sub PullData()
Dim repDate As Date
Dim tmpFileStr As String
Dim tmpPathStr As String
Dim rowCtrLng As Long
Dim startRowCtrLng As Long
Dim stoptRowCtrLng As Long
Dim msgStr As String
Dim currentDate As Date
Dim stopDate
Dim fldName As String
Dim fName As String
Dim fDay As String
'On Error GoTo errHandler
'Initialize row counter
startRowCtrLng = 2
'Get starting row for new data
Do While ThisWorkbook.ActiveSheet.Range("B" & startRowCtrLng).Value <> ""
startRowCtrLng = startRowCtrLng + 1
Loop
rowCtrLng = startRowCtrLng
'Assign current date to variable
'Pause automatic calculation
Application.Calculation = xlCalculationManual
'Disable alerts
Application.DisplayAlerts = False
repDate = Format(ThisWorkbook.Worksheets("Database").Range("A" & rowCtrLng).Value, "mm/dd/yyyy")
currentDate = Date
fldName = Format(Year(Now), "0000")
fName = Format(Month(Now), "00")
fDay = Format(Day(Now), "0")
'Begin looping through date range
Do While repDate < currentDate
tmpFileStr = ""
tmpPathStr = ""
'Determine if report exists
tmpPathStr = "\\0.0.0.0\dept\Folder\Subfolder\" & fldName & "\"
If Dir("\\0.0.0.0\dept\Folder\Subfolder\" & fldName & "\" & fName & "-" & fldName & ".xls") <> "" Then
tmpFileStr = fName & "-" & fldName & ".xls"
Else
tmpFileStr = ""
End If
If tmpFileStr <> "" Then
'build Links
'Production Date
ThisWorkbook.ActiveSheet.Range("A" & rowCtrLng).Value = repDate
'Crush
ThisWorkbook.ActiveSheet.Range("B" & rowCtrLng).Value = "='" & tmpPathStr & "[" & tmpFileStr & "]C vol'!$C$7"
End If
rowCtrLng = rowCtrLng + 1
repDate = ThisWorkbook.Worksheets("Database").Range("A" & rowCtrLng).Value
Loop
End Sub
'
I have a .xlsx file in the following directory:
G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx
I could just point it to this directory but the directory will change depending on the year it is.
So this directory could become:
G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\9. 2018\2018 Planner.xlsx
To handle this i am trying to add wildcards to my path like so:
G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "*." & " " & Year(Date) & "\"
My workbook will not open.
Please can someone show me where i am going wrong?
Sub:
'Find Planner
If Len(FindDepotMemo) Then
Set wb2 = Workbooks.Open(FindDepotMemo, ReadOnly:=True, UpdateLinks:=False)
End If
Function:
Function FindDepotMemo() As String
Dim Path As String
Dim FindFirstFile As String
Path = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\" & "*." & " " & Year(Date) & "\"
FindFirstFile = Dir$(Path & "*.xlsx")
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Planner") > 0 Then
FindDepotMemo = Path & FindFirstFile
Exit Function
End If
FindFirstFile = Dir
Wend
End Function
There are many ways but, I would use this approach:
Function FindDepotMemo() As String
Dim oldPath, tempPath, newPath As String
Dim FindFirstFile As String
Dim addInt as Integer
' ASSUMING YOU ALREADY HAVE THIS PATH
' WE WILL USE THIS AS BASE PATH
' AND WE WILL INCREMENT THE NUMBER AND YEAR IN IT
oldPath = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017"
' EXTRACT 8. 2017 FROM oldPath
tempPath = Mid(oldPath, InStrRev(oldPath, "\") + 1)
' GET THE YEAR DIFFERENCE
addInt = Year(Date) - CInt(Split(tempPath, ".")(1))
' ADD THIS DIFFERENCE TO NUMBER AND YEAR
' AND NOW YOU HAVE CURRENT YEAR FOLDER
newTemp = Split(tempPath, ".")(0) + addInt & ". " & Split(tempPath, ".")(1) + addInt
FindFirstFile = Dir$(Path & "\" & "*.xlsx")
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Test") > 0 Then
FindDepotMemo = Path & FindFirstFile
Exit Function
End If
FindFirstFile = Dir
Wend
End Function
As I've added comments to help you understand what am I doing.
Try this approach. The code loops through folder names 1. 2020, 1. 2019, 1. 2018 and current year, finding the lowest one, say, 1. 2018 exists. For that year it then looks for the highest month number, abandoning the previous for the next higher. If, say, 4. 2018 exists that is the path in which it looks for the file name using your original code.
Function FindDepotMemo() As String
Dim Pn As String ' Path name
Dim Fn As String ' Folder name
Dim Sp() As String ' Split string
Dim Arr() As String, Tmp As String
Dim FindFirstFile As String
Dim i As Integer
Dim n As Integer
For i = 2020 To Year(Date) Step -1
Pn = "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\1. " & CStr(i) & "\"
If Len(Dir(Pn, vbDirectory)) Then Exit For
Next i
If i >= Year(Date) Then
Sp = Split(Pn, "\")
Arr = Sp
n = UBound(Sp) - 1
Fn = Sp(n)
For i = 2 To 12
Arr(n) = CStr(i) & Mid(Fn, 2)
Pn = Join(Arr, "\")
If Len(Dir(Pn, vbDirectory)) = 0 Then Exit For
Sp = Arr
Next i
FindFirstFile = Join(Sp, "\") & "*.xlsx"
While (FindFirstFile <> "")
If InStr(FindFirstFile, "Planner") > 0 Then
FindDepotMemo = Pn & FindFirstFile
Exit Do
End If
FindFirstFile = Dir
Wend
End If
End Function
If no 1. 2017 or higher is found, the function returns a null string. I couldn't test the code for lack of data.
I have a module function in this report that concatenates certain cells:
Function AnalysisResults(Specs As Range, Results As Range)
AnalysisResults = Join(Specs) & ";" & Replace(Join(Results), ",", ".")
End Function
Private Function Join(Range As Range, Optional ByRef Delimeter As String = " ")
Dim Str As String
For Each cell In Range
If Str <> "" Then Str = Str & Delimeter
Str = Str & cell.Value
Next
Join = Str
End Function
Then i have a command button that save my file as CSV. It works, but the where the function cells are the value saved is #NAME?.
If I Save As manually as CSV comma delimited, it saves correctly and the formula values appears.
Here is the code of the CommandButton:
Dim myValue As Variant
myValue = InputBox("Specifica numele WBT-ului de descarcare:", "Save WBT with the following name", 1)
Range("L2").Value = myValue
Dim CopyToCSV()
Dim MyPath As String
Dim MyFileName As String
Sheets("Manual Discharge WBT").EnableCalculation = True
MyPath = "\\FILES\Transfer\~~TTS Import (do not delete)~~\Import Files\"
MyFileName = Range("L2") & " Discharge " & Format(CStr(Now), " dd_mm_yyyy_hh_mm")
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
Sheets("Manual Discharge WBT").Copy
With ActiveWorkbook
.SaveAs Filename:= _
MyPath & MyFileName, _
FileFormat:=xlCSVWindows, _
CreateBackup:=False
.Close False
MsgBox "Fisierul tau s-a salvat ca: " & MyFileName
End With
The solution is, you will have to save your AnalysisResults and Join functions as an add-in file .xlam and add to excel at Developer->Add-ins. Doing it this way the above code worked for me when saving to CSV without #NAME?
What was happening here was that when excel is trying to save the file to CSV, it doesn't know what the AnalysisResults function is.
Here is my VBA code.
It currently opens all excel documents in a file that are xlsx and the name of each document ends with "Daily" in the name. I have unfortunately just found that several users of these documents will be accessing them through a much older version of excel "2000" and my VBA will not work with their versions?
Can someone help me? Changing xlsx to xls just crashes my system.**
Option Explicit
Public Sub processFiles()
Dim strProductivityFiles As String, strProductivityArchive As String,
strProductivityResult As String
Let Application.DisplayAlerts = False
Let strProductivityFiles = "\*Daily.xlsx*"
Let strProductivityArchive = "\Archive\"
Let strProductivityResult = "\daily_productivity.txt"
AgentProductivity strProductivityFiles, strProductivityArchive,
strProductivityResult
Let Application.DisplayAlerts = True
Application.ActiveWorkbook.Close
End Sub
Private Sub AgentProductivity(strImportFile As String, strArchivePath As
String, strResultFile As String)
Dim wbk As Workbook
Dim wbkData As Workbook
Dim wksData As Worksheet
Dim namData As Name
Dim ranData As Range
Dim ranCell As Range
Dim strAgent As String
Dim strQueue As String
Dim datDate As Date
Dim dblVolume As Double
Dim dblTime As Double
Dim lngArrayRow As Long
Dim varOutput() As Variant
ReDim varOutput(200000, 12)
Set wbk = Application.ActiveWorkbook
If (Dir(wbk.Path & strResultFile) <> "") Then
Kill wbk.Path & strResultFile
End If
Let strImportFile = Dir(wbk.Path & strImportFile)
Let lngArrayRow = 0
Do While strImportFile <> ""
If Right(strImportFile, 4) = "xlsx*" Then
Set wbkData = Workbooks.Open(wbk.Path & "\" & strImportFile)
'Let lngArrayRow = 0
'ReDim Preserve varOutput(20000, 5)
For Each namData In wbkData.Names
If (namData.Name = "Data") Then
Set ranData = Range(namData)
End If
If (namData.Name = "User") Then
Let strAgent = Range(namData).Value
End If
Next namData
For Each ranCell In ranData
If (ranCell.Row >= 3) And (ranCell.Column >= 3) And ((ranCell.Row
Mod 2) > 0) Then
Let strQueue = Cells(ranCell.Row, 1)
Let datDate = Cells(2, ranCell.Column)
Let dblVolume = Cells(ranCell.Row + 1, ranCell.Column)
Let dblTime = Cells(ranCell.Row, ranCell.Column)
If (dblVolume > 0) Or (dblTime > 0) Then
Let varOutput(lngArrayRow, 0) = strAgent
Let varOutput(lngArrayRow, 1) = strQueue
Let varOutput(lngArrayRow, 2) = datDate
Let varOutput(lngArrayRow, 3) = dblVolume
Let varOutput(lngArrayRow, 4) = dblTime
Let lngArrayRow = lngArrayRow + 1
End If
End If
Next ranCell
wbkData.SaveAs wbk.Path & strArchivePath & wbkData.Name,
xlOpenXMLWorkbook
wbkData.Close
Let strImportFile = Dir()
End If
Loop
ExportData5Fields wbk.Path & strResultFile, varOutput
End Sub
Private Sub ExportData5Fields(strFile As String, varArray() As Variant)
Dim lngFile As Long
Let lngFile = FreeFile()
Dim lngCounter As Long
If (Dir(strFile) <> "") Then
Open strFile For Append As #lngFile
Else
Open strFile For Append As #lngFile
Print #lngFile, """" & "CitrixID" & """," & _
"""" & "Workstream" & """," & _
"""" & "Date" & """," & _
"""" & "Volume" & """," & _
"""" & "Minutes" & """"
End If
For lngCounter = 0 To UBound(varArray, 1)
If Not IsEmpty(varArray(lngCounter, 0)) Then
Print #lngFile, """" & varArray(lngCounter, 0) & """," & _
"""" & varArray(lngCounter, 1) & """," & _
"""" & varArray(lngCounter, 2) & """," & _
"""" & varArray(lngCounter, 3) & """," & _
"""" & varArray(lngCounter, 4) & """"
End If
Next lngCounter
enter code here
Close #lngFile
End Sub
The VBA would work however Excel 2000 cannot by default open .xlsx files.
Either have whatever is generating the files in the first place switch to generating .xls format files or install the Office 2007 Compatibility Pack on machines running Office 2000 to enable them to work with the newer format files.
I have a small piece of code under a command button click which saves the workbook file with a new name in a new location, I am wondering if it is possible to also automatically create a shortcut to that newly saved workbook in a different location?
Private Sub CommandButton1_Click()
Dim SelectedFNumber As String
Dim DateStr As String
Dim myFileName As String
Dim StorePath As String
DateStr = Format(Now, "dd.mm.yy HH.mm")
SelectedFNumber = Range("B4").Text
If SelectedFNumber <> "SELECT F NUMBER" And Range("D11") > "0" Then
StorePath = "G:\Targets\" & SelectedFNumber & "\"
myFileName = StorePath & SelectedFNumber & " " & DateStr & ".xlsm
If Len(Dir(StorePath, vbDirectory)) = 0 Then
MkDir StorePath
End If
ActiveWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
MsgBox "Select an F Number"
End If
End Sub
You basically need to add something like this:
Dim sShortcutLocation As String
sShortcutLocation = "C:\blah\workbook shortcut.lnk"
With CreateObject("WScript.Shell").CreateShortcut(sShortcutLocation)
.TargetPath = myFileName
.Description = "Shortcut to the file"
.Save
End With
changing the location to wherever you want.