excel宏将一个文件夹复制到另一个文件夹，文件夹名称由用户输入

Question

我正在尝试通过 excel 宏将一个完整的文件夹复制到一个新文件夹中，但我每次都需要用户输入新的文件夹名称

这是我复制到永久/静态文件夹的当前代码

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

我想出了一种方法让用户输入文件夹名称，但无法将此名称链接到正在创建的新文件夹

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

我需要将“StrName”放在以下上下文中才能正常工作，但似乎无法获得正确的语法

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

Answer 1

也许像下面这样？

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

要连接 Text/String 只需使用 & (& 符号) 。 +(plus) 也可以，但我对&很满意

Answer 2

谢谢，我知道问题出在哪里了 :) 基本上我必须将 StrName 添加到
FSO.CopyFolder Source:=FromPath, Destination:=ToPath & strName

有时最简单的问题是最糟糕的，哈哈。感谢您的帮助

以下是最终代码，以备其他人卡住时参考

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

'''''******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