excel vba根据部分文件名移动文件

我有场景，我需要将文件移动到另一个位置基于部分文件名称。 例如，“FAI 741727-001 SMS CQ 6U PASS 061217.xlsx”是文件名，我想创build另一个位置为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列中的单元格，find与单元格值匹配的文件，从当前date和单元格值创build子文件夹并移动文件。

 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 

现在，对于需要在string中查找字符的部分，你不能只是做这样的事情。

= MID（A1，FIND（ “CQ”，A1,1）+3,2）

填写下来，拿起一切。