问excel vba基于部分文件名移动文件

EN

Public Sub MoveFiles()
    On Error GoTo ErrProc

    'Today's date folder
    Dim today As String
        today = Format(Date, "dd.mm.yyyy") 'Change this to the format you wish

    Dim r As Range, c As Range
    Set r = Range(Cells(2, 2), Cells(Cells(Rows.Count, "B").End(xlUp).Row, 2)) 'Column B

    Dim filesCollection As Collection, idx As Long
    With CreateObject("Scripting.FileSystemObject")
        For Each c In r
            'Create a Collection of files matching pattern in column B
            Set filesCollection = New Collection

            FillCollectionWithFilePattern obj:=filesCollection, path:=c.Offset(0, [-1]).Value, pattern:=c.Value

            For idx = 1 To filesCollection.Count
                'Validate source exist
                If Len(Dir(.BuildPath(c.Offset(0, [-1]).Value, filesCollection(idx)))) > 0 Then
                    .MoveFile Source:=.BuildPath(c.Offset(0, [-1]).Value, filesCollection(idx)), _
                              Destination:=.BuildPath(PathFromNewFolders(c.Offset(0, [-1]).Value, today, c.Value), filesCollection(idx))
                End If
            Next idx
            Set filesCollection = Nothing
        Next c
    End With

    MsgBox "Completed.", vbInformation

Leave:
    Set filesCollection = Nothing
    On Error GoTo 0
    Exit Sub

ErrProc:
    MsgBox Err.Description, vbCritical
    Resume Leave
End Sub

'Find files matching pattern and add to Collection
Private Sub FillCollectionWithFilePattern(obj As Collection, ByVal path As String, pattern As String)

    Dim strFile As String
        strFile = Dir(AddPathSeparator(path) & "*" & pattern & "*.xlsx")

    Do While Len(strFile) > 0
        obj.Add strFile
        strFile = Dir
    Loop
End Sub

'Creates a new folder (if not exists) for each argument
Public Function PathFromNewFolders(ByVal path As String, ParamArray args() As Variant) As String

    path = AddPathSeparator(path)

    Dim idx As Integer
    For idx = LBound(args) To UBound(args)
        If Len(Dir(path & args(idx), vbDirectory)) = 0 Then MkDir path & args(idx)
        path = path & args(idx) & "\"
    Next idx

    PathFromNewFolders = path
End Function

'Adds PathSeparator '\' to the end of path if mising
Private Function AddPathSeparator(ByVal path As String) As String
    path = Trim(path)
    If Right(path, 1) <> "\" Then path = path & "\"
    AddPathSeparator = path
End Function

Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change

    'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    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