VBA to copy-paste the last created Excel file inside of a folder and naming it.

netanel99 · May 3rd 2021

I've tested the whole code, it works pretty good unless the user choose a name with "." , then it creates a file with no excel extention ".xlms". (like: new name 2.4.21 - that's it without .xlms)

Is it possible to change the code that instead of asking the user for a name, the code will choose a name automatically , and the name will be "new name"+Today date ? that will be seriously awesome.

for example executing the code today will give a name of:

New Name 3.5.21

and tomorrow will be

New Name 4.5.21

and so on .

just wondering if that possible with fixing the problem that the code doesn't give excel extension when a "." involved in the name.

it makes the whole code bitter sweet .

thank you already for all the help .

Netanel

Code

Option Explicit

Private Sub CommandButton1_Click()
 Dim wbNew As Workbook
 Dim sPath As String, sFil As String, sLastFil As String
 Dim dLastDate As Date, sLastModified As Date
 Dim iCnt As Integer
 Dim ans As Variant
 ''///change the file path
 sPath = ThisWorkbook.Path & Application.PathSeparator & "library"
 If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
 sFil = Dir(sPath & "*.xls*", vbNormal)
 If Len(sFil) = 0 Then
 MsgBox "No files were found...", vbExclamation
 Exit Sub
 End If
 Do While Len(sFil) > 0 And sFil <> ThisWorkbook.Name
 sLastModified = FileDateTime(sPath & sFil)
 If sLastModified > dLastDate Then
 sLastFil = sFil
 dLastDate = sLastModified
 End If
 sFil = Dir
 Loop
prompt_again:
 iCnt = iCnt + 1
 If iCnt < 3 Then
 ans = InputBox("Please Enter a name for the new workbook", "Enter Name")
 If Len(ans) = 0 Then GoTo prompt_again
 Else: Exit Sub
 End If
 Application.ScreenUpdating = False
 Set wbNew = Workbooks.Open(sPath & sLastFil)
 wbNew.SaveAs sPath & ans, 52 ''///51 = xlsx 52= xlms
 wbNew.Close False
 
  With ThisWorkbook.Sheets("Products & Services Contents").Range("B" & Rows.Count).End(xlUp).Offset(1)
 .Value = ans
 ActiveSheet.Hyperlinks.Add _
 Anchor:=.Offset(, -1), _
 Address:=(sPath & ans & ".xlsm"), _
 TextToDisplay:="Link"
 Workbooks.Open sPath & ans

 End With
End Sub

Display More

**royUK** · May 3rd 2021

Try this. It removes "." if the user adds one when entering the name. Then adds the data to the end of the file name, which is always a good idea when duplicating workbooks.

Code

Option Explicit
Private Sub CommandButton1_Click()
    Dim wbNew As Workbook
    Dim sPath As String, sFil As String, sLastFil As String
    Dim dLastDate As Date, sLastModified As Date
    Dim iCnt As Integer
    Dim ans As Variant
    '///change the file path
    sPath = ThisWorkbook.Path & Application.PathSeparator & "library"
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sFil = Dir(sPath & "*.xls*", vbNormal)
    If Len(sFil) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    Do While Len(sFil) > 0 And sFil <> ThisWorkbook.Name
        sLastModified = FileDateTime(sPath & sFil)
        If sLastModified > dLastDate Then
            sLastFil = sFil
            dLastDate = sLastModified
        End If
        sFil = Dir
    Loop
prompt_again:
    iCnt = iCnt + 1
    If iCnt < 3 Then
        ans = InputBox("Please Enter a name for the new workbook", "Enter Name")
        If Len(ans) = 0 Then GoTo prompt_again
        Else: Exit Sub
    End If
    ''/// avoid "." at end
    If Right(ans, 1) = "." Then ans = Left(ans, Len(ans) - 1)
    Application.ScreenUpdating = False
    Set wbNew = Workbooks.Open(sPath & sLastFil)
    
    wbNew.SaveAs sPath & ans & " " & Format(Date, "dd.mm.yy"), 52 ''///51 = xlsx 52= xlms
    wbNew.Close False
    
    With ThisWorkbook.Sheets("Products & Services Contents").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .Value = ans
        ActiveSheet.Hyperlinks.Add _
        Anchor:=.Offset(, -1), _
        Address:=(sPath & ans & ".xlsm"), _
        TextToDisplay:="Link"
        Workbooks.Open sPath & ans
        
    End With
End Sub

Display More

netanel99 · May 9th 2021

Thanks Roy , it was a journey , I really made new insights, understanding and skills in VBA .

sorry for the delay, my laptop fell and I got short circuit in one of the mother board component, this is my older laptop that I just furnished .

My last piece in the puzzle is making this exact code work for a folder, that means instead of finding the last edited/created file in a folder the code will find the last edited/created folder in a folder - and then copy paste it .

Is it possible as a finisher bro ?
I'm on it, really surprised myself with VBA in the last week, but I think I need one last help in this one.

best regards,

Netanel

Code

Option Explicit
Private Sub CommandButton1_Click()
 Dim wbNew As Workbook
 Dim sPath As String, sFil As String, sLastFil As String
 Dim dLastDate As Date, sLastModified As Date
 Dim iCnt As Integer
 Dim ans As Variant
 ''///change the file path
 sPath = ThisWorkbook.Path & Application.PathSeparator & "library"
 If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
 sFil = Dir(sPath & "*.xls*", vbNormal)
 If Len(sFil) = 0 Then
 MsgBox "No files were found...", vbExclamation
 Exit Sub
 End If
 Do While Len(sFil) > 0 And sFil <> ThisWorkbook.Name
 sLastModified = FileDateTime(sPath & sFil)
 If sLastModified > dLastDate Then
 sLastFil = sFil
 dLastDate = sLastModified
 End If
 sFil = Dir
 Loop
prompt_again:
 iCnt = iCnt + 1
 If iCnt < 3 Then
 ans = InputBox("Please Enter a name for the new workbook", "Enter Name")
 If Len(ans) = 0 Then GoTo prompt_again
 Else: Exit Sub
 End If
 Application.ScreenUpdating = False
 Set wbNew = Workbooks.Open(sPath & sLastFil)
 wbNew.SaveAs sPath & ans, 52 ''///51 = xlsx 52= xlms
 wbNew.Close False
 
 With ThisWorkbook.Sheets("Products & Services Contents").Range("B" & Rows.Count).End(xlUp).Offset(1)
 .Value = ans
 ActiveSheet.Hyperlinks.Add _
 Anchor:=.Offset(, -1), _
 Address:=(sPath & ans & ".xlsm"), _
 TextToDisplay:="Link"
 Workbooks.Open sPath & ans
 End With
End Sub

Display More

netanel99 · May 9th 2021

I just wandered 4 hours on the internet and realized that finding the last modified/created folder in a specific directory is extremely tough VBA challenge

Hope I'll keep my hair after this last challenge of death

**royUK** · May 9th 2021

I'll take a look later

netanel99 · May 9th 2021

Quote

I'll take a look later

YYYAAAAYYY ! The smell of hope is uplifting !

netanel99 · May 9th 2021

I was thinking on a second possible solution that will be also amazing -that instead of finding the last edited/created folder inside a folder and copy-paste it , there will be a systematically naming of the new folder instead of asking the user for a name , like this:

Code

ans = "new folder" & " - " & Format(Date, "dd-mmm-yyyy")

so the code could search for the folder with the highest value- the latest number if that possible (because I need the folder with the most recent date )- so the newest folder always will get picked and the code will copy -paste the last one. which I have no idea how to do but I was keep thinking on it for the last who knows how many hours.

Code

Option Explicit
Private Sub CommandButton1_Click()
 Dim wbNew As Workbook
 Dim sPath As String, sFil As String, sLastFil As String
 Dim dLastDate As Date, sLastModified As Date
 Dim iCnt As Integer
 Dim ans As Variant
 ''///change the file path
 sPath = ThisWorkbook.Path & Application.PathSeparator & "library"
 If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
 sFil = Dir(sPath & "*.xls*", vbNormal)
 If Len(sFil) = 0 Then
 MsgBox "No files were found...", vbExclamation
 Exit Sub
 End If
 Do While Len(sFil) > 0 And sFil <> ThisWorkbook.Name
 sLastModified = FileDateTime(sPath & sFil)
 If sLastModified > dLastDate Then
 sLastFil = sFil
 dLastDate = sLastModified
 End If
 sFil = Dir
 Loop
prompt_again:
 iCnt = iCnt + 1
 If iCnt < 3 Then
 ans = "new folder" & " - " & Format(Date, "dd-mmm-yyyy")
 If Len(ans) = 0 Then GoTo prompt_again
 Else: Exit Sub
 End If
 Application.ScreenUpdating = False
 Set wbNew = Workbooks.Open(sPath & sLastFil)
 wbNew.SaveAs sPath & ans, 52 ''///51 = xlsx 52= xlms
 wbNew.Close False
 
 With ThisWorkbook.Sheets("Products & Services Contents").Range("B" & Rows.Count).End(xlUp).Offset(1)
 .Value = ans
 ActiveSheet.Hyperlinks.Add _
 Anchor:=.Offset(, -1), _
 Address:=(sPath & ans & ".xlsm"), _
 TextToDisplay:="Link"
 Workbooks.Open sPath & ans
 End With
End Sub

Display More

Thanks ! Thanks ! THANKS!!!

Be Blessed.

**royUK** · May 9th 2021

Here's a UDF to get the name of the newest subfolder.

Code

Function GetLastFolder(P As String)
    Dim FSO As Object, SF, F
    Dim LastDate As Date
    Set FSO = CreateObject("scripting.FileSystemObject")
    Set SF = FSO.GetFolder(P).SubFolders
    For Each F In SF
        If F.DateLastModified > LastDate Then
             LastDate = F.DateLastModified
              GetLastFolder = F.Name
        End If
    Next
End Function

Sub Test()
MsgBox GetLastFolder("c:\Temp")
End Sub

Display More

**royUK** · May 9th 2021

Do you mean like this?

Code

Private Sub CommandButton1_Click()
    Dim wbNew As Workbook
    Dim sPath As String, sFil As String, sLastFil As String
    Dim dLastDate As Date, sLastModified As Date
    Dim iCnt As Integer
    Const NewFile As String = "Library"
    ''///change the file path
    sPath = ThisWorkbook.Path & Application.PathSeparator & "library"
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sFil = Dir(sPath & "*.xls*", vbNormal)
    If Len(sFil) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    Do While Len(sFil) > 0 And sFil <> ThisWorkbook.Name
        sLastModified = FileDateTime(sPath & sFil)
        If sLastModified > dLastDate Then
            sLastFil = sFil
            dLastDate = sLastModified
        End If
        sFil = Dir
    Loop
    
    Application.ScreenUpdating = False
    Set wbNew = Workbooks.Open(sPath & sLastFil)
    wbNew.SaveAs sPath & NewFile & " - " & Format(Date, "dd-mmm-yyyy"), 52  ''///51 = xlsx 52= xlms
    wbNew.Close False
    
    With ThisWorkbook.Sheets("Products & Services Contents").Range("B" & Rows.Count).End(xlUp).Offset(1)
        .Value = ans
        ActiveSheet.Hyperlinks.Add _
        Anchor:=.Offset(, -1), _
        Address:=(sPath & ans & ".xlsm"), _
        TextToDisplay:="Link"
        Workbooks.Open sPath & ans
    End With
End Sub

Display More

netanel99 · May 9th 2021

That looks so awesome that I'll give myself a little sleep now, so I'll wake up fresh to work on it , thank you so much Roy! never I was learning so much VBA in what feels to me like a very high level , and you just swim like a shark in it.

much appreciation for a giant help .

**royUK** · May 9th 2021

Almost twenty years learning!

netanel99 · May 9th 2021

Thanks for sharing!!!

netanel99 · May 10th 2021

Code

Function GetLastFolder(P As String)
 Dim FSO As Object, SF, F
 Dim LastDate As Date
 Set FSO = CreateObject("scripting.FileSystemObject")
 Set SF = FSO.GetFolder(P).SubFolders
 For Each F In SF
 If F.DateLastModified > LastDate Then
 LastDate = F.DateLastModified
 GetLastFolder = F.Name
 End If
 Next
End Function

Display More

Thanks Roy!

Pls, how can I sign this beauty to give value ?

I was trying

Code

sub FunctionGiveValue ()
dim GetNewestFolderValue as string

GetNewestFolderValue = GetLastFolder ("ThisWorkbook.Path & Application.PathSeparator & "library"")     ' failed

end sub

I was trying to use it with dynamic path instead of static one ("C:\folder") which unfortunately failed

thanks for all,

Netanel.

netanel99 · May 11th 2021

sorry my bad it works the path was too long that why the code failed : )

Finished the heavy lifting , thanks for the help bro !

**royUK** · May 11th 2021

Pleased to help.

VBA to copy-paste the last created Excel file inside of a folder and naming it.

Participate now!

Share

Users Viewing This Thread