Remove Photos From One Folder To Another Using VBA

[Dazzawm]

I have a folder with thousands of photos, I believe it is possible to move them to another folder according to a list in column A of a spreadsheet using VBA. Any ideas how to please?

 

[Dazzawm]

Any ideas anyone please?

 

[jolivanes]

Re: "list in column A"
What is in this list? Existing names I assume. What about the path?

 

[jolivanes]

Change references as required. Both assume header in row 1

If you have only the picture name incl extension in Column A and the paths are as indicated.

Sub Maybe_So()
Dim pathOld As String, pathNew As String, c As Range
pathOld = "C:\AAAAAA\"    '<---- Folder where the pictures to be moved are in.
pathNew = "C:\AAAAAA\AAA\"    '<---- Folder where the pictures should be moved to.
    For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        Name pathOld & c.Value As pathNew & c.Value
    Next c
End Sub

If you have the Picture names including path and extension in Cells in Column A (Like "C:\Folder 1\Folder 2\Nice Photo.jpg")

Sub Maybe_So_With_Path()
Dim pathNew As String, c As Range
pathNew = "C:\AAAAAA\AAA\"    '<---- Folder where the pictures should be moved to.
    For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        Name c.Value As pathNew & Mid(c.Value, InStrRev(c.Value, "\") + 1)
    Next c
End Sub

 

[Dazzawm]

Sub Maybe_So() Dim pathOld As String, pathNew As String, c As Range pathOld = "C:\AAAAAA\" '<---- Folder where the pictures to be moved are in. pathNew = "C:\AAAAAA\AAA\" '<---- Folder where the pictures should be moved to. For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Name pathOld & c.Value As pathNew & c.Value Next c End Sub

Thanks. I had a debug and it pointed to this line.

Name pathOld & c.Value As pathNew & c.Value

 

[Dazzawm]

Someone please help!! I need it asap for work!!

 

[Dazzawm]

Panic over, I found this on the internet if it helps anyone else.

Sub movefiles()
'Updateby Extendoffice
    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:", "KuTools For Excel", 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