VBA脚本用于创建文件夹并将具有特定条件的文件移动到这些文件夹

Question

客户端具有包含两列的XLSX文件。第一列列出了需要创建的子文件夹，第二列列出了以客户编号开头的PDF文件的客户编号：

例如：https://imgur.com/a/J5VrorN

我需要一个脚本帮助为单元格A1中指定的文件夹下的第1列中的条目创建子文件夹，然后移动第2列中以相同的16个字符编号开头的所有PDF文件

（即：4573415225783909_01-13-2018_monthly_statement.PDF，4573415225783909_01-14-2018_monthly_statement.PDF）向新创建的子文件夹中与文件相关的文件夹。

摘要：创建文件夹ABC23913，将以4573415225783909开头的所有文件移动到该文件夹​​。

我想出了创建子文件夹宏：

Sub CreateDirs()

    Dim R As Range

    For Each R In Range("A2:A1000")
        If Len(R.Text) > 0 Then
            On Error Resume Next
            Shell ("cmd /c md " & Chr(34) & Range("A1") & "\" & R.Text & Chr(34))
            On Error GoTo 0
        End If
    Next R 

End Sub

第二部分，我有一段时间了。我在网上发现这是关闭的，但是除非整个文件名在列中并且不自动移动，否则不会移动文件。

Sub movefiles()

    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String

    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "Brad", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub

    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = " Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub

    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = " Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub

    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"

    For Each xCell In xRg
        xVal = xCell.Value

        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
            Kill xSPathStr & xVal
        End If
    Next

End Sub

我可以感觉到我很亲密，但我对VBA知之甚少，无法正确查找和移动文件。

一个温暖的饼干给任何可以帮助我解决这个烂摊子的人。

Answer 1

你可以在一个功能中做所有事情

Sub Create()


Dim wb As Workbook
Dim ws As Worksheet
Dim DefaultPath As String
Dim NewFolderPath As String
Dim FileName As String
Dim pdfFiles As String
Dim Fobj As Object
Dim NumOfItems As Long

Set Fobj = CreateObject("scripting.filesystemobject")


Set wb = ActiveWorkbook
Set ws = wb.Worksheets("sheet1")

DefaultPath = "C:\"


With ws
    NumOfItems = .Cells(Rows.Count, 1).End(xlUp).Row
    For Each Item In .Range(.Cells(2, 1), .Cells(NumOfItems, 1))
        NewFolderPath = DefaultPath & Item.Value
        If Fobj.folderexists(NewFolderPath) = False Then
            MkDir (NewFolderPath)
        End If

        pdfFiles = Dir(DefaultPath & "*.pdf")

        Do While pdfFiles <> ""
            If InStr(1, pdfFiles, .Cells(Item.Row, 2)) > 0 Then
                FileName = pdfFiles

                Fobj.MoveFile Source:=DefaultPath & FileName, Destination:=NewFolderPath & "\" & FileName
            End If
            pdfFiles = Dir
        Loop
    Next Item

End With

End Sub