excel vba根據部分文件名移動文件

Question

我有場景，我需要根據部分文件名將文件移動到另一個位置。例如，「FAI 741727-001 SMS CQ 6U PASS 061217.xlsx」是文件名，我想創建另一個位置爲6U，然後將該文件移動到該文件夾​​。

我有一個代碼，可以幫助我將文件移動到一個文件夾只有當我給完整的文件名。是否有人可以幫助我在這..

代碼：

Sub MoveFiles() 

Dim SourcePath As String 
Dim DestPath As String 
Dim FileName As String 
Dim LastRow As Long 
Dim i As Long 

LastRow = Cells(Rows.Count, "A").End(xlUp).Row 

For i = 1 To LastRow 

    FileName = Cells(i, "B").Value 

    If Right(Cells(i, "A").Value, 1) <> Application.PathSeparator Then 
     SourcePath = Cells(i, "A").Value & Application.PathSeparator 
    Else 
     SourcePath = Cells(i, "A").Value 
    End If 

    If Right(Cells(i, "C").Value, 1) <> Application.PathSeparator Then 
     DestPath = Cells(i, "C").Value & Application.PathSeparator 
    Else 
     DestPath = Cells(i, "C").Value 
    End If 

    If Dir(SourcePath & FileName) = "" Then 
     Cells(i, "D").Value = "Source file does not exist." 
    ElseIf Dir(DestPath & FileName) <> "" Then 
     Cells(i, "D").Value = "File already exists." 
    Else 
     Name SourcePath & FileName As DestPath & FileName 
     Cells(i, "D").Value = "File moved to new location" 
    End If 

Next i 

End Sub 

Answer 1

循環遍歷B列中的單元格，找到與單元格值匹配的文件，從當前日期創建子文件夾&單元格值和移動文件。

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 

Answer 2

複製部分應該是非常簡單的。看看下面的腳本。

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 

現在，對於需要在字符串中查找字符的部分，你不能只是做這樣的事情。

= MID（A1，FIND（ 「CQ」，A1,1）+3,2）

填寫撿起一切。