备份（移动）文件
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
