我正在尝试通过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
答案 0 :(得分：2)
也许就像下面一样？
ToPath = "C:\Users\hayekn\Desktop\AR Reports\0MENACA Working File\AR Working File\Week" & StrName
要连接文本/字符串，只需使用&（＆符号）。 +（加号）也有效，但我对&
答案 1 :(得分：0)
谢谢，我想出问题出在哪里:)
基本上我必须将StrName添加到
FSO.CopyFolder来源：= FromPath，目的地：= ToPath＆amp;则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
答案 2 :(得分：0)
'''''******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