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

复制部分应该非常简单。看看下面的脚本。

array

现在，对于你需要在字符串中找到字符的部分，你不能做这样的事情。

= MID（A1，FIND（＆＃34; CQ＆＃34;，A1,1）+3,2）

填写下来以获取所有内容。

excel vba根据部分文件名

2 个答案: