Question

在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

Answer 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

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

1 个答案: