Question

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

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

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

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

我知道了create子文件夹宏：

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

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

1 个答案: