VBA script to create folders and move files with certain criteria to those folders

A client has an XLSX file that contains two columns. First columns lists the sub-folders that need to be created, the 2nd column lists Customer Numbers for PDF files that that start with the Customer Number:

example: https://imgur.com/a/J5VrorN

I need help with a script to create sub-folders for entries in column 1 under the folder specified in cell A1, then move all the PDF files that begin with the same 16 character number in column 2

(ie: 4573415225783909_01-13-2018_monthly_statement.PDF, 4573415225783909_01-14-2018_monthly_statement.PDF) to the newly created sub-folder the folder related to the file.

4573415225783909_01-13-2018_monthly_statement.PDF

4573415225783909_01-14-2018_monthly_statement.PDF

Summary: Create folder ABC23913, move any files that start with 4573415225783909 to that folder.

I figured out the create sub-folders macro:

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


I'm have a hell of a time with the 2nd part. I found this online which is close, but does not move the file unless the entire file name is in the column and does not move it automatically.

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


I can feel that I am close, but I don't know enough about VBA to have it find and move the files correctly.

A warm cookie to anyone that can help me with this mess.

1 Answer
1

you can do every thing in one function

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


By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.