Question : Moving and Renaming Files using Excel/VB

I have a good working script that renames all files within a directory, based off an Excel Spreadsheet. Everything is working great... But I'd like to take it to the next phase.

Instead of simply renaming the files, I'd like to do the rename, as well as place them inside another sub-directory of the original, based off a column in the spreadsheet.

The spreadsheet in question, is a list of students at our school, and one of the columns includes homeroom teacher.

Would somebody happen to know the code I could use that would (when combined with the rename files script I've attached) - also creates a sub-folder based on teacher, then moves the files into the new location?

Thanks in advance.

Code Snippet:

         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:

           
           
             Sub RenameFiles()
   Dim lngRow As Long, lngRowCount As Long, lngStartRow As Long
   Dim strPath As String
   On Error Resume Next
   strPath = "C:\Pictures"
   
   If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
   lngRowCount = Cells(65536, "A").End(xlUp).Row
   lngStartRow = 1
   Application.ScreenUpdating = False
   For lngRow = lngStartRow To lngRowCount
      If Len(Cells(lngRow, "A").Value) > 0 And Len(Cells(lngRow, "B").Value) > 0 Then
         Name strPath & Cells(lngRow, "A").Value As strPath & Cells(lngRow, "B").Value
         Cells(lngRow, "C").Value = "Renamed"
      End If
   Next lngRow
   Application.ScreenUpdating = True
End Sub

           
         

Open in New Window

Select All

Answer : Moving and Renaming Files using Excel/VB

Try it like this:

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:

           
           
             Sub RenameFiles()
   Dim lngRow As Long, lngRowCount As Long, lngStartRow As Long
   Dim f As String, strPath As String, newPath As String
   On Error Resume Next
   strPath = "C:\Pictures\"
   
   lngRowCount = Cells(65536, "C").End(xlUp).Row
   lngStartRow = 1
   Application.ScreenUpdating = False
   For lngRow = lngStartRow To lngRowCount
      If (Cells(lngRow, "C") <> "") And (Cells(lngRow, "K") <> "") And (Cells(lngRow, "I") <> "") Then
         newPath = "C:\Pictures\" & Cells(lngRow, "I")      'Homeroom folder
         f = Dir(newPath, 16)       'Returns a blank if folder is missing
         If f = "" Then MkDir newPath     'If homeroom folder is missing, must create one before moving file
         Name strPath & Cells(lngRow, "C") As newPath & "\" & Cells(lngRow, "K")    'Move the file
         Cells(lngRow, "L") = "Renamed"
      End If
   Next
   Application.ScreenUpdating = True
End Sub
           
         

Open in New Window

Select All