使用excel 2010 vba将所有xlsx文件从目录移动到另一个答案

【问题标题】：move all xlsx files from directory to another using excel 2010 vba使用excel 2010 vba将所有xlsx文件从目录移动到另一个
【发布时间】：2016-01-14 22:46:07
【问题描述】：

在FromPath 中有4 个xlsx 文件我想移动到变量MyDirectory。目前vba 运行，但是当它到达这一点时，文件仍保留在临时目录（FromPath）中并且不会被移动，我不知道为什么。谢谢你:)。

vba

'TRANSFER FROM TEMP '
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String

FromPath = "C:\Users\cmccabe\Desktop\EmArray\*.xlsx"
ToPath = "MyDirectory"


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

编辑

Private Sub CommandButton21_Click()
Dim MyBarCode   As String      ' Enter Barcode
Dim MyScan      As String      ' Enter ScanDate
Dim MyDirectory As String

'GET USER INPUT '
Line1:
MyBarCode = Application.InputBox("Please enter the last 5 digits of the barcode", "Bar Code", Type:=2)

If MyBarCode = "False" Then Exit Sub   'user canceled
Do
    MyScan = Application.InputBox("Please enter scan date", "Scan Date", Date - 1, Type:=2)
    If MyScan = "False" Then Exit Sub   'user canceled
    If IsDate(MyScan) Then Exit Do
    MsgBox "Please enter a valid date format. ", vbExclamation, "Invalid Date Entry"
Loop

'CREATE NEXUS DIRECTORY AND VERIFY FOLDER '
MyDirectory = "N:\1_DATA\MicroArray\NexusData\" & "2571683" & MyBarCode & "_" & Format(CDate(MyScan), "m-d-yyyy") & "\"
If Dir(MyDirectory, vbDirectory) = "" Then
    MkDir MyDirectory
Else
    MsgBox ("Already exsists! Please enter again")
    GoTo Line1
End If

' TRANSFER FILES '
 Dim MyFile As String

MyFile = Dir("C:\Users\cmccabe\Desktop\EmArray\*.xlsx")

Do Until MyFile = ""

Name "C:\Users\cmccabe\Desktop\EmArray\*.xlsx" & MyFile As "N:\1_DATA\MicroArray\NexusData\" & "2571683" & MyBarCode & "_" & Format(CDate(MyScan), "m-d-yyyy") & MyFile

MyFile = Dir

Loop
End Sub

【问题讨论】：

topath 需要更明确吗？ C:\Users\Christophe\Desktop\MyDirectory\ 你也没有检查 MyDirectory 文件夹是否存在......
MyDirectory 是在用户输入之前的步骤中创建的...。我将尝试使 ToPath 更明确。谢谢你:)。
CopyFolder 不接受文件掩码 (*.xlsx)。它复制整个文件夹，而不是单个文件，并且它不会移动（复制到新目标并从旧目标中删除），它复制。（这就是为什么它被命名为 CopyFolder。）请参阅this question 中的代码 - 该问题询问有关从多个文件夹中递归移动文件的问题，但它有用于 moving 文件的代码而不是而不仅仅是复制它们。
这可能会有所帮助：stackoverflow.com/questions/26241927/…
我添加了一个编辑，其中用户输入 # 并将其存储为变量，然后用户输入日期，该日期也存储为变量。在transfer files 部分中，所有 xlsx 文件都应该发送到这些变量，但我收到了错误的文件名错误。谢谢你:)。

标签： excel vba

【解决方案1】：

有代码可以在文件夹中查找所有 xlsx 文件以用于其他目的，通过 for/next 循环运行所有文件并找到最后带有 .xlsx 的文件，如果您有数百万，这将非常缓慢且效率低下要排序的文件。

Dim f As Object, fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

For Each f In fso.getfolder(Folder).Files
    If Left(f.Name, Len(ContractNumber)) = ContractNumber And Right(f.Name, 4) = "xlsx" Then
        f.CopyFile Source:=FromPath, Destination:=ToPath
    End If
Next

【讨论】：