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

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

例如：

我需要一个脚本帮助，以便在单元格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

子移动文件（）
尺寸xRg作为范围，xCell作为范围
Dim xSFileDlg As FileDialog、xDFileDlg As FileDialog
Dim xSPathStr作为变体，xDPathStr作为变体
作为字符串的Dim xVal
出错时继续下一步
设置xRg=Application.InputBox（“请选择文件名：”、“Brad”、ActiveWindow.RangeSelection.Address、、、8）
如果xRg为Nothing，则退出Sub
Set xSFileDlg=Application.FileDialog（msoFileDialogFolderPicker）
xSFileDlg.Title=“请选择原始文件夹：”
如果xSFileDlg.Show为-1，则退出Sub
xSPathStr=xSFileDlg.SelectedItems.Item（1）和“\”
设置xDFileDlg=Application.FileDialog（msoFileDialogFolderPicker）
xDFileDlg.Title=“请选择目标文件夹：”
如果xDFileDlg.Show为-1，则退出Sub
xDPathStr=xDFileDlg.SelectedItems.Item（1）和“\”
对于xRg中的每个xCell
xVal=xCell.Value
如果TypeName（xVal）=“字符串”和xVal“”，则
文件拷贝xSPathStr&xVal，xDPathStr&xVal
杀死xSPathStr&xVal
如果结束
下一个
端接头

我可以感觉到我已经很接近了，但是我对VBA了解不够，无法让它正确地查找和移动文件

---

给任何能帮我解决这个麻烦的人一块热饼干。

你可以在一个函数中完成每件事

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

子创建（）
将wb设置为工作簿
将ws设置为工作表
将默认路径设置为字符串
将NewFolderPath设置为字符串
将文件名设置为字符串
将pdfFiles设置为字符串
作为对象的Dim Fobj
将所有项目视为长项目
Set Fobj=CreateObject（“scripting.filesystemobject”）
设置wb=ActiveWorkbook
设置ws=wb.工作表（“表1”）
DefaultPath=“C:\”
与ws
NumOfItems=.Cells（Rows.Count，1）.End（xlUp）.Row
对于.Range（.Cells（2，1），.Cells（NumOfItems，1））中的每个项
NewFolderPath=DefaultPath和Item.Value
如果Fobj.folderexists（NewFolderPath）=False，则
MkDir（NewFolderPath）
如果结束
pdfFiles=Dir（DefaultPath&“*.pdf”）
在pdfFiles“”时执行
如果InStr（1，pdfFiles，.Cells（Item.Row，2））>0，则
FileName=pdfFiles
Fobj.MoveFile源：=DefaultPath和文件名，目标：=NewFolderPath和“\”文件名
如果结束
pdfFiles=Dir
环
下一项
以
端接头

感谢您的帮助，我收到一个错误：编译错误：参数不是可选的，它指向第一行。请告知。嗨，Brad E，您可能需要在参考中启用脚本运行时。错误：CreateObject高亮显示了吗？Ryeo，对不起，我做了更多的挖掘，我让它工作了。我必须更改工作表名称和文件路径。我在工作！非常感谢你！