希望你做得很好！
你能帮我用什么代码将文件移动到它们各自的文件夹，但只使用部分文件名吗？我已经成功创建了单独的子文件夹，但我不知道如何将文件移动到它们各自的文件夹中。 Here is my working file.
这是我创建文件夹的代码：
Sub MakeFolders()
Application.ScreenUpdating = False
Sheets("LIST").Select
Range("G12").Select
ActiveCell.Formula2R1C1 = _
"=UNIQUE(FILTER(RC[-2]:R[188]C[-2],RC[-2]:R[188]C[-2]<>""""))"
Range("G12").Select
Range(Selection, Selection.End(xlDown)).Select
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
Sheets("LIST").Select
Range("G12").Select
Selection.ClearContents
MsgBox ("PM folders created.")
End Sub
我可以在此处添加什么以将文件移动到创建的文件夹中？
非常感谢！
答案 0 :(得分：0)
试试这个 - 它会同时移动文件并创建子文件夹：
Sub MoveFilesToSubfolders()
Const START_ROW As Long = 12 'first row with data
Dim wb As Workbook, ws As Worksheet, files As Collection, rw As Range, f
Dim thefile, fldr, workFolder As String
Set wb = ActiveWorkbook 'or ThisWorkbook if that's where the macro is...
Set ws = wb.Worksheets("LIST")
Set rw = ws.Rows(START_ROW) 'first row with data
workFolder = wb.Path
'add terminating \ if missing
If Right(workFolder, 1) <> "\" Then workFolder = workFolder & "\"
Do While Len(rw.Columns("B").Value) > 0
fldr = rw.Columns("E").Value
If Len(Dir(workFolder & fldr, vbDirectory)) = 0 Then
MkDir (workFolder & fldr)
End If
'find any matching files
Set files = GetFileMatches(workFolder, "*" & rw.Columns("B").Value & "*.zip")
If files.Count > 0 Then
For Each f In files 'loop over matched files and move them
Name workFolder & f As workFolder & fldr & "\" & f
Next f
Else
MsgBox "No file(s) found for row# " & rw.Row
End If
'next row down
Set rw = rw.Offset(1)
Loop
End Sub
'Return a collection of file paths given a starting folder and a file pattern
' e.g. "*.txt"
Function GetFileMatches(startFolder As String, filePattern As String) As Collection
Dim f, colFiles As New Collection
If Right(startFolder, 1) <> "\" Then startFolder = startFolder & "\"
f = Dir(startFolder & filePattern) 'find first file
Do While Len(f) > 0
colFiles.Add f
f = Dir() 'next file(s) if exist
Loop
Set GetFileMatches = colFiles
End Function
答案 1 :(得分：0)
BackupFiles，其余的正在被调用。Option Explicit
Sub BackupFiles()
Const wsName As String = "LIST"
Const foFirst As String = "E2"
Const fiCol As String = "B"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Folder Range
Dim forg As Range: Set forg = RefColumn(ws.Range(foFirst))
If forg Is Nothing Then Exit Sub
Dim foData As Variant: foData = GetColumn(forg)
' File Range
Dim firg As Range: Set firg = forg.EntireRow.Columns(fiCol)
Dim fiData As Variant: fiData = GetColumn(firg)
' Source Folder Path
Dim sPath As String: sPath = wb.Path & "\"
' All Files in the Source Folder
Dim FilePaths As Variant: FilePaths = ArrFilePaths(sPath, 1)
Dim FileNames As Variant: FileNames = ArrFileNames(sPath, 1)
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim fsoFile As Object
Dim rIndex As Variant
Dim r As Long
Dim dPath As String ' Destination Folder Path
For r = 1 To UBound(foData)
rIndex = Application.Match("*" & fiData(r, 1) & "*", FileNames, 0)
If IsNumeric(rIndex) Then
dPath = sPath & foData(r, 1) & "\"
If Not fso.FolderExists(dPath) Then
fso.CreateFolder dPath
End If
Set fsoFile = Nothing
On Error Resume Next
' Prevent "Run-time Error 53: File not found" i.e.
' if a file contains several strings, it has been moved already.
Set fsoFile = fso.Getfile(FilePaths(rIndex))
On Error GoTo 0
If Not fsoFile Is Nothing Then
If fso.FileExists(dPath & FileNames(rIndex)) Then
fsoFile.Copy dPath ' , True ' overwriting by default
fsoFile.Delete
Else
fsoFile.Move dPath
End If
End If
End If
Next r
MsgBox "Files moved.", vbInformation, "Backup Files"
End Sub
Function RefColumn( _
ByVal FirstCellRange As Range) _
As Variant
If FirstCellRange Is Nothing Then Exit Function
With FirstCellRange.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
Function GetColumn( _
ByVal ColumnRange As Range) _
As Variant
If ColumnRange Is Nothing Then Exit Function
With ColumnRange.Columns(1)
Dim Data As Variant
If .Cells.Count = 1 Then
ReDim Data(1 To 1, 1 To 1): Data = .Value
Else
Data = .Value
End If
GetColumn = Data
End With
End Function
Function ArrFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FirstIndex As Long = 0) _
As Variant
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolderPath) Then
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
Dim FilesCount As Long: FilesCount = fsoFolder.Files.Count
If FilesCount > 0 Then
Dim n As Long: n = FirstIndex - 1
Dim arr As Variant: ReDim arr(FirstIndex To FilesCount + n)
Dim fsoFile As Object
For Each fsoFile In fsoFolder.Files
n = n + 1
arr(n) = fsoFile.Path
Next fsoFile
ArrFilePaths = arr
End If
End If
End Function
Function ArrFileNames( _
ByVal FolderPath As String, _
Optional ByVal FirstIndex As Long = 0) _
As Variant
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolderPath) Then
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)
Dim FilesCount As Long: FilesCount = fsoFolder.Files.Count
If FilesCount > 0 Then
Dim n As Long: n = FirstIndex - 1
Dim arr As Variant: ReDim arr(FirstIndex To FilesCount + n)
Dim fsoFile As Object
For Each fsoFile In fsoFolder.Files
n = n + 1
arr(n) = fsoFile.Name
Next fsoFile
ArrFileNames = arr
End If
End If
End Function