excel Macro to copy one folder to another folder with folder name entered by user

Question

I am trying to copy a complete folder into a new folder through excel macro, but i need the new folder name to be entered by the user every time

This is the current code i have that copies to a permanent/static folder

Sub Copy_Folder()

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String

FromPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\3- FINAL Country Files\1"  '<< Change
ToPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\Weekly Back" '<< Change

Application.CutCopyMode = False

If Right(FromPath, 1) = "\" Then
    FromPath = Left(FromPath, Len(FromPath) - 1)
End If

If Right(ToPath, 1) = "\" Then
    ToPath = Left(ToPath, Len(ToPath) - 1)
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

I worked out a way for the user to enter a folder name, but unable to link this name to the new folder being created

Dim strName As String
Dim WeekStr1 As String
Dim WeekStr2 As String

Reenter:
strName = InputBox(Prompt:="Enter the week you would like to update", _
Title:="Week Selection.", Default:="0")

If strName = vbNullString Then
Exit Sub

Else
    Select Case strName

    Case Else
    MsgBox "Incorrect Entry."
    GoTo Reenter
    End Select

End If

I need the "StrName" to be placed in the following context for it to work, but cant seem to get the right syntax

ToPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\Week "StrName"" '<< Change

Answer 1

'''''******you need to select folder to copy to different location, first select file 
           folder then select newfolderpath
 ***********''''''''''' you can copy all files through subfolder into one folder 

Sub Copyfilesintosub()

    Dim fso As Scripting.FileSystemObject
    Dim fillfolder As Scripting.Folder
    Dim fill As Scripting.File
    Dim filefolder As Folder
    Dim filepath As String
    Dim abc As String
    Dim subfolder As Folder
    Dim mesboxresule As VbMsgBoxResult
    Dim fd As FileDialog
    Dim ivalu As String
    Dim dum As String
    Dim inp As String
    Dim fpath As String
    Dim chfail As Boolean
        
        Set fso = New Scripting.FileSystemObject
       
        mesboxresule = MsgBox("select yes to pick folder, else no", vbYesNo + vbInformation, "Decicion making by " & Environ("Username"))
          
          If mesboxresule = vbYes Then
        
            Set fd = Application.FileDialog(msoFileDialogFolderPicker)
            
            fd.ButtonName = "Go"
            fd.Title = "Please Select Folder to copy data"
            fd.InitialFileName = Environ("Userprofile") & "\" & "\Desktop"
            fd.InitialView = msoFileDialogViewProperties
            If chfail = fd.Show Then
                MsgBox "you didn't pick folder, Please try again", vbCritical + vbApplicationModal + vbSystemModal, "Please run again"
            Exit Sub
                    
            Else
                    
             filepath = fd.SelectedItems(1)
                
             End If
            
           ElseIf mesboxresule = vbNo Then
            
            filepath = Environ("UserProfile") & "\Desktop\" & Environ("Username")
         
         End If
    
            Set fillfolder = fso.GetFolder(filepath)
            
            Set fd = Application.FileDialog(msoFileDialogFolderPicker)
            
            fd.ButtonName = "Go"
            fd.Title = "Please Select Folder to paste data"
            fd.InitialFileName = Environ("Userprofile") & "\" & "\Desktop"
            fd.InitialView = msoFileDialogViewProperties
                           
                 If chfail = fd.Show Then
                    MsgBox "you didn't pick folder, Please try again", vbCritical + vbApplicationModal + vbSystemModal, "Please try again"
                    
                Exit Sub
                    
                Else
                    fpath = fd.SelectedItems(1)
                
                End If
               
               For Each subfolder In fillfolder.SubFolders
            
                    Debug.Print subfolder.Name
            
                    For Each fill In subfolder.Files
                
                        dum = fill.Name
        
                            ivalu = InStr(1, dum, "%")
        
                                If ivalu > 0 Then
            
                                    ActiveCell.Value = fill.Name
            
                                    ivalu = ActiveCell.Replace("%", "")
            
                                     dum = ActiveCell.Value
            
                                    fill.Name = dum
                            
                                End If
         
                                    If fill Like "*.xlsx" Or fill Like "*.xls" Or fill Like "*.xlsm" Then
                    
                                        If Not fso.FileExists(fpath & "\" & fill.Name) Then
                
                                            fill.Copy fpath & "\" & fill.Name
                                            
                                        End If
                        
                                    End If
           
                     Next fill
                        
            Next subfolder
    
              Dim count As Long
               MsgBox "done"
                       
               Dim hg As Scripting.File
               
               Dim hgg As Scripting.Folder
               
               Dim count1 As Long
               
               Set hgg = fso.GetFolder(fpath)
               
               Dim subfolder1 As Folder
               
               For Each subfolder1 In hgg.SubFolders
               
               Next subfolder1
                        For Each fill In fillfolder.Files
                        
                             Debug.Print fill.Name
                             
                             dum = fill.Name
                             
                             ivalu = InStr(1, dum, "%")
                                
                                If ivalu > 0 Then
                                
                                    ActiveCell.Value = fill.Name
                                    
                                    ivalu = ActiveCell.Replace("%", "")
                                    
                                    dum = ActiveCell.Value
                                    
                                    fill.Name = dum
                                  
                                End If
                                
                                If fill Like "*.xlsx" Or fill Like "*.xls" Or fill Like "*.xlsm" Then
                    
                                        If Not fso.FileExists(fpath & "\" & fill.Name) Then
                
                                            fill.Copy fpath & "\" & fill.Name
                                            
                                        End If
                                    End If
    
                        Next fill
                        
                        Dim count2 As Long
                        
                        count2 = count2 + hgg.Files.count
                        
                        Dim finalcount As Long
                        
                        finalcount = count2
                        
                        MsgBox finalcount
                        
                        MsgBox "Done", vbExclamation, "copying data Succesful"
    
          End Sub

Answer 2

Thank you, I figured out where the issue was :) Basically i had to add StrName to
FSO.CopyFolder Source:=FromPath, Destination:=ToPath & strName

Sometimes the simplest issues are the worst lol. thanks for your help

Below is the final code for future reference in case anyone else gets stuck

Sub Copy_Folder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim strName As String
Dim WeekStr1 As String
Dim WeekStr2 As String

FromPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\3- FINAL Country Files\KSA"  '<< Change
ToPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\Week"
Application.CutCopyMode = False


Reenter:
strName = InputBox(Prompt:="Enter the week you would like to update", _
Title:="Week Selection.", Default:="0")

If strName = vbNullString Then
MsgBox "Incorrect Entry."
GoTo Reenter

End If

If Right(FromPath, 1) = "\" Then
    FromPath = Left(FromPath, Len(FromPath) - 1)
End If

If Right(ToPath, 1) = "\" Then
    ToPath = Left(ToPath & strName, Len(ToPath) - 1)
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

FSO.CopyFolder Source:=FromPath, Destination:=ToPath & strName
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath & strName

Answer 3

Perhaps like below?

ToPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\Week" & StrName

To concatenate Text/String simply use & (ampersand) . +(plus) works too but I'm comfortable with &