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）

填写捡起一切。