Copying files from one location to another based on a list, but don't always know the file extension

[oreo haven]

I have thousands of images in a single folder that need to be copied into other folders, based on a list.
I have the path to the image, and the path to the new folder. However, I have a mix of file types.
On the example I show the file extension, but that isn't currently something I have in my list. I'm just showing it for an example.
Does anyone have some code that will take the file listed in G (without the file extension) and move it to the path in H? I realize having the name in H is probably not necessary.

If I need the file extensions, I can get it, it will just be some more work.

 

[Micron]

It would be better if you could just work from the folder and forget the list. However, if you found the last dot (.) in a file name in the folder by using InstrRev function, you'd have its position count from the left side of the file name. So for Test.jpg that would be 4. Mid function could return all on the left side of the dot - Mid("Test.jpg",1,4) = Test, and you compare that to your list items. This would not work if some list values have the extension and some don't. Also, if your list had
Bird in it, you'd copy over
Bird.jpg, Bird.jpeg, Bird.Tiff, Bird.png and so on.

I don't have code for this by the way; just trying to suggest the logic. If it were me, I might open two file explorer windows, multi select, copy and paste (or drag to move). Writing the code would take longer than it does to manually copy over.

 

[oreo haven]

Manually moving would be easier, if it weren't for the shear volume. I have 3,692 documents/images that must be moved to 335 different locations.

 

[johnnyL]

I have thousands of images in a single folder that need to be copied into other folders, based on a list.
I have the path to the image, and the path to the new folder. However, I have a mix of file types.
On the example I show the file extension, but that isn't currently something I have in my list. I'm just showing it for an example.
Does anyone have some code that will take the file listed in G (without the file extension) and move it to the path in H? I realize having the name in H is probably not necessary.

If I need the file extensions, I can get it, it will just be some more work.

Is the following a more accurate representation of what you have now, as an example:

Book1
	G	H
1	CURRENT LOCATION	NEW LOCATION
2	C:\STUFF\IMAGE1	C:\STUFF\137564\IMAGE
3	C:\STUFF\FOO	C:\STUFF\137564\FOO
4	C:\STUFF\INVOICE5	C:\STUFF\137564\INVOICE5
5	C:\STUFF\8675309	C:\STUFF\139462\8675309
Sheet1

As @Micron mentioned, if you don't know the extension, you would be copying multiple same file names with different extensions, if such a possibility were to exist.
I guess you could narrow down the scope of extensions, if multiple same names were a possibility, by only allowing certain file extensions.

Also wanted to ask if you truly want to copy the files, or 'move' them? You mentioned copy in one post and then move in another post.

 

[oreo haven]

Copy or move, it is immaterial as far as my needs go.. Hitting the deadline, so a paralegal will have to figure it out now. HAHAHAHA

 

[johnnyL]

So are you saying you no longer need a solution?

 

[oreo haven]

Yes, no longer need the solution. I found something that looked promising on another thread, but couldn't get it to work. Going to keep playing with it, in case the need arises in the future. Always nice to have a bit of knowledge tucked away. Thank you all for the replies.

 

[johnnyL]

Just for giggles, try the following code which attempts to find the missing extensions of all the path\file names provided:

Book1
	F	G	H	I
1		CURRENT LOCATION	NEW LOCATION
2		C:\STUFF\Text 21.9.2022	C:\STUFF\137564\IMAGE
3		C:\STUFF\FOO	C:\STUFF\137564\FOO
4		C:\STUFF\INVOICE5	C:\STUFF\137564\INVOICE5
5		C:\STUFF\8675309	C:\STUFF\139462\8675309
6
Sheet1

Option Explicit


Sub GetExtensions()
'
    Dim ResultsSheetMissing             As Boolean
    Dim SourceLastRow                   As Long
    Dim RowNumber                       As Long
    Dim FilesToMoveRange                As Range
    Dim FileToMovePath                  As String
    Dim FileNameAndExtensionInPath      As String
    Dim FileNameFromFilesToMoveRange    As String
    Dim FileNameFromPath                As String
    Dim HeaderTitlesToPaste             As Variant
    Dim ResultsSheetName                As String
    Dim DestinationWS                   As Worksheet
    Dim SourceWS                        As Worksheet
    Dim File                            As Variant
'
    ResultsSheetName = "Results Sheet"                                                                              ' <--- Set this to the name of the destination sheet
    Set SourceWS = Sheets("Sheet1")                                                                                 ' <--- Set this to the name of the source sheet
'
    HeaderTitlesToPaste = Array("Original Search with No Extension", "Found Files with Extensions")                 ' Header row to paste to destination sheet
'
    SourceLastRow = SourceWS.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row                              ' Get LastRow of Source sheet
'
    Set FilesToMoveRange = SourceWS.Range("G2:G" & SourceLastRow)                                                   ' G2:G5
'
    ResultsSheetMissing = Evaluate("IsError(Cell(""col"",'" + ResultsSheetName + "'!A1))")                          ' If ResultsSheetMissing = False then the sheet does exist
'
    If ResultsSheetMissing = False Then                                                                             ' If the ResultsSheetName exists then
        Application.DisplayAlerts = False                                                                           '   Turn DisplayAlerts off ... sheet deletion causes popup
        Sheets(ResultsSheetName).Delete                                                                             '   Delete the sheet
        Application.DisplayAlerts = True                                                                            '   Turn DisplayAlerts back on
    End If
'
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = ResultsSheetName                                                 ' Add the ResultsSheet & name it
    Set DestinationWS = Sheets(ResultsSheetName)                                                                    ' Set the DestinationWS
'
    DestinationWS.Range("A1:B1").Value = HeaderTitlesToPaste                                                        ' Write header row to DestinationSheet
'
    For Each File In FilesToMoveRange                                                                               ' Loop through the files in FilesToMoveRange
        FileNameFromFilesToMoveRange = Mid(File, InStrRev(File, "\") + 1)                                           '   Get characters after last '\' in string ... "Text 21.9.2022"
        FileToMovePath = Left(File, InStrRev(File, "\"))                                                            '   Get characters before last '\' including last '\' in string ... "C:\STUFF\"
'
        If Right(FileToMovePath, 1) <> "\" Then                                                                     '   If FileToMovePath doesn't end with a '\' then ...
            FileToMovePath = FileToMovePath & "\"                                                                   '       append a '\' to the end of FileToMovePath
        End If
'
        FileNameAndExtensionInPath = Dir(FileToMovePath & "*.*")                                                    '   Get FileNameAndExtensionInPath found in the FileToMovePath ... "Text 21.9.2022.xlsm"
        RowNumber = 2                                                                                               '   Initialize RowNumber
'
        Do While FileNameAndExtensionInPath <> ""                                                                   '   Loop while files are being found FileToMovePath
            FileNameFromPath = Left(FileNameAndExtensionInPath, InStrRev(FileNameAndExtensionInPath, ".") - 1)      '       Get characters before last '.' in string ... "Text 21.9.2022"
'
            If InStr(LCase(FileNameFromPath), LCase(FileNameFromFilesToMoveRange)) > 0 Then                         '       If the file name from the path = file name we are looking for then ...
                DestinationWS.Range("A" & RowNumber) = File                                                         '           Save the original search to the destinatin sheet
                DestinationWS.Range("B" & RowNumber) = FileToMovePath & FileNameAndExtensionInPath                  '           Save the original search & file extension found to the destination sheet
'
                RowNumber = RowNumber + 1                                                                           '           Increment RowNumber
            End If
'
            FileNameAndExtensionInPath = Dir                                                                        '       See if there is another file in the path
        Loop                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    Columns("A:B").AutoFit                                                                                          ' Autofit the columns of the destination sheet
'
' Clean up
    Set DestinationWS = Nothing                                                                                     '
    Set SourceWS = Nothing                                                                                          '
    Set FilesToMoveRange = Nothing                                                                                  '
End Sub

Results I got:

Book1
	A	B	C
1	Original Search with No Extension	Found Files with Extensions
2	C:\STUFF\Text 21.9.2022	C:\STUFF\Text 21.9.2022.xlsm
3	C:\STUFF\Text 21.9.2022	C:\STUFF\Text 21.9.2022.xlsx
4
Results Sheet

After that, you could use the column with the found extensions for the copying/moving of files.

 

[johnnyL]

For future reference, the following code should do what you wanted, get the file extensions and move the files to a different location:

Sub GetExtensionsV2()
'
    Dim ResultsSheetMissing                 As Boolean
    Dim ArrayRow                            As Long, RowNumber                              As Long
    Dim SourceLastRow                       As Long
    Dim MaxFileNameMatchesExpected          As Long
    Dim ProblemFileCounter                  As Long
    Dim FileNameAndExtensionInPath          As String, FileNameFromSearchPath               As String
    Dim FileNameFromFilesToMoveRange        As String, PathFromFilesToMoveRange             As String
    Dim ResultsSheetName                    As String
    Dim HeaderTitlesToPaste                 As Variant
    Dim ProblemFilesArray()                 As String
    Dim FilesToMoveArray                    As Variant, FilesWithExtensionsToMoveArray()    As Variant
    Dim CorrespondingNewLocationsArray()    As Variant, NewLocationsArray                   As Variant
    Dim DestinationWS                       As Worksheet, SourceWS                          As Worksheet
'
'-------------------------------------------------------------------------------------------------------------------
'
    MaxFileNameMatchesExpected = 50000                                                                              ' <--- Set this to the maximum # of File name matches that may be found
    ResultsSheetName = "Results Sheet"                                                                              ' <--- Set this to the name of the destination sheet
    Set SourceWS = Sheets("Sheet1")                                                                                 ' <--- Set this to the name of the source sheet
'
'-------------------------------------------------------------------------------------------------------------------
'
    HeaderTitlesToPaste = Array("Original Search with No Extension", "Found Files with Extensions", "New Location of File", "", "Files Found But Not Moved") ' Header row to paste to destination sheet
'
    SourceLastRow = SourceWS.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row                              ' Get LastRow of Source sheet
'
    FilesToMoveArray = SourceWS.Range("G2:G" & SourceLastRow)                                                       ' Load the FilesToMove into 2D 1 based FilesToMoveArray
    NewLocationsArray = SourceWS.Range("H2:H" & SourceLastRow)                                                      ' Load the NewLocations into 2D 1 based NewLocationsArray
'
    ResultsSheetMissing = Evaluate("IsError(Cell(""col"",'" + ResultsSheetName + "'!A1))")                          ' If ResultsSheetMissing = False then the sheet does exist
'
    If ResultsSheetMissing = False Then                                                                             ' If the ResultsSheetName exists then
        Application.DisplayAlerts = False                                                                           '   Turn DisplayAlerts off ... sheet deletion causes popup
        Sheets(ResultsSheetName).Delete                                                                             '   Delete the sheet
        Application.DisplayAlerts = True                                                                            '   Turn DisplayAlerts back on
    End If
'
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = ResultsSheetName                                                 ' Add the ResultsSheet & name it
    Set DestinationWS = Sheets(ResultsSheetName)                                                                    ' Set the DestinationWS
'
    DestinationWS.Range("A1:E1").Value = HeaderTitlesToPaste                                                        ' Write header row to DestinationSheet
'
    ReDim FilesWithExtensionsToMoveArray(1 To MaxFileNameMatchesExpected, 1 To 1)                                   ' Establish the # of rows & columns for the 2D 1 based FilesWithExtensionsToMoveArray
    ReDim CorrespondingNewLocationsArray(1 To MaxFileNameMatchesExpected, 1 To 1)                                   ' Establish the # of rows & columns for the 2D 1 based CorrespondingNewLocationsArray
'
'-------------------------------------------------------------------------------------------------------------------
'
    RowNumber = 0                                                                                                   ' Initialize RowNumber
'
    For ArrayRow = 1 To UBound(FilesToMoveArray, 1)                                                                 ' Loop through the rows in FilesToMoveArray
        FileNameFromFilesToMoveRange = Mid$(Trim(FilesToMoveArray(ArrayRow, 1)), _
                InStrRev(Trim(FilesToMoveArray(ArrayRow, 1)), "\") + 1)                                             '   Get characters after last '\' in string
        PathFromFilesToMoveRange = Left$(Trim(FilesToMoveArray(ArrayRow, 1)), InStrRev(Trim(FilesToMoveArray(ArrayRow, 1)), "\")) '   Get characters before last '\' including last '\' in string
'
        If Right$(PathFromFilesToMoveRange, 1) <> "\" Then PathFromFilesToMoveRange = PathFromFilesToMoveRange & "\"    '   If PathFromFilesToMoveRange doesn't end with a '\' then Append a '\' to the end of PathFromFilesToMoveRange
'
'        FileNameAndExtensionInPath = Dir$(PathFromFilesToMoveRange & "*.*")                                                   '   Get FileNameAndExtensionInPath found in the PathFromFilesToMoveRange
        FileNameAndExtensionInPath = Dir$(PathFromFilesToMoveRange)                                                 '   Get FileNameAndExtensionInPath found in the PathFromFilesToMoveRange
'
        Do While FileNameAndExtensionInPath <> ""                                                                   '   Loop while files are being found in the PathFromFilesToMoveRange
            FileNameFromSearchPath = Left$(FileNameAndExtensionInPath, InStrRev(FileNameAndExtensionInPath, ".") - 1)   '       Get characters before last '.' in string
'
            If InStr(LCase(FileNameFromSearchPath), LCase(FileNameFromFilesToMoveRange)) > 0 Then                   '       If the file name from the path = file name we are looking for then ...
                RowNumber = RowNumber + 1                                                                           '           Increment RowNumber
'
                FilesWithExtensionsToMoveArray(RowNumber, 1) = PathFromFilesToMoveRange & FileNameAndExtensionInPath    '           Save the original search & file extension found to FilesWithExtensionsToMoveArray
'
                If Right$(Trim(NewLocationsArray(ArrayRow, 1)), 1) <> "\" Then                                      '           If the NewLocation Path does not end with '\' then ...
                    CorrespondingNewLocationsArray(RowNumber, 1) = Trim(NewLocationsArray(ArrayRow, 1)) & "\"       '               Save the NewLocation Path & '\' to the CorrespondingNewLocationsArray
                Else                                                                                                '           Else ...
                    CorrespondingNewLocationsArray(RowNumber, 1) = Trim(NewLocationsArray(ArrayRow, 1))             '               Save just the NewLocation Path to the CorrespondingNewLocationsArray
                End If
            End If
'
            FileNameAndExtensionInPath = Dir$                                                                       '       See if there is another file in the path
        Loop                                                                                                        '   Loop back
    Next                                                                                                            ' Loop back
'
    DestinationWS.Range("A2").Resize(UBound(FilesToMoveArray, 1), UBound(FilesToMoveArray, 2)) = FilesToMoveArray   ' Display the FilesToMoveArray to the destination sheet in it's original form
    DestinationWS.Range("B2").Resize(UBound(FilesWithExtensionsToMoveArray, 1), _
            UBound(FilesWithExtensionsToMoveArray, 2)) = FilesWithExtensionsToMoveArray                             ' Display the FilesWithExtensionsToMoveArray to the destination sheet
    DestinationWS.Range("C2").Resize(UBound(CorrespondingNewLocationsArray, 1), _
            UBound(CorrespondingNewLocationsArray, 2)) = CorrespondingNewLocationsArray                             ' Display the CorrespondingNewLocationsArray to the destination sheet
'
    DestinationWS.UsedRange.Columns.AutoFit                                                                         ' Autofit the columns of the destination sheet
'
'-------------------------------------------------------------------------------------------------------------------
'
    FilesWithExtensionsToMoveArray = ReDimPreserve(FilesWithExtensionsToMoveArray, RowNumber, 1)                    '
    CorrespondingNewLocationsArray = ReDimPreserve(CorrespondingNewLocationsArray, RowNumber, 1)                    '
'
    For ArrayRow = 1 To UBound(FilesWithExtensionsToMoveArray, 1)                                                   ' Loop through all rows of the FilesWithExtensionsToMoveArray
        On Error GoTo ErrorHandler                                                                                  '   Enable our error-handling routine
'
        If Dir$(FilesWithExtensionsToMoveArray(ArrayRow, 1)) <> "" Then                                             '       If FilesWithExtensionsToMove exists then ...
            If Dir$(CorrespondingNewLocationsArray(ArrayRow, 1), vbDirectory) <> "" Then                            '           If CorrespondingNewLocations exists then ...
'
                FileNameFromFilesToMoveRange = Mid$(Trim(FilesWithExtensionsToMoveArray(ArrayRow, 1)), _
                        InStrRev(Trim(FilesWithExtensionsToMoveArray(ArrayRow, 1)), "\") + 1)                       '               Get characters after last '\' in string

                Name FilesWithExtensionsToMoveArray(ArrayRow, 1) As _
                        CorrespondingNewLocationsArray(ArrayRow, 1) & FileNameFromFilesToMoveRange                  '               Move the file
            End If
        End If
'
CheckNextFile:
        On Error GoTo 0                                                                                             '   Return Error handling back over to Excel
    Next                                                                                                            ' Loop back
'
    If Not Not ProblemFilesArray Then                                                                               ' If any files couldn't be moved then ...
'
        DestinationWS.Range("E2").Resize(UBound(ProblemFilesArray)) _
                = Application.Transpose(ProblemFilesArray)                                                          '   Display the problem file names to the results sheet
        DestinationWS.Columns(5).AutoFit                                                                            '   Adjust the column width of column E to display entire file names
    End If
'
' Clean up
    Set DestinationWS = Nothing                                                                                     '
    Set SourceWS = Nothing                                                                                          '
    Exit Sub                                                                                                        ' exit the sub
'
'-------------------------------------------------------------------------------
'
ErrorHandler:
    ProblemFileCounter = ProblemFileCounter + 1                                                                     ' Increment ProblemFileCounter
    ReDim Preserve ProblemFilesArray(1 To ProblemFileCounter)                                                       ' Increase the size of the ProblemFilesArray
    ProblemFilesArray(ProblemFileCounter) = FilesWithExtensionsToMoveArray(ArrayRow, 1)                             ' Save the file path and name of the file that wasn't moved into ProblemFilesArray
    Resume CheckNextFile                                                                                            ' Remove error encountered and return back to check for the next file
End Sub


Public Function ReDimPreserve(ArrayNameToPreserve, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Redim & preserve both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
    Dim NewColumn                   As Long, NewRow             As Long
    Dim OldColumnUbound             As Long, OldRowUbound       As Long
    Dim NewArrayNameToPreserve()    As Variant
'
    ReDimPreserve = False
'
    If IsArray(ArrayNameToPreserve) Then                                                                    ' If the variable is an array then ...
        ReDim NewArrayNameToPreserve(NewRowUbound, NewColumnUbound)                                         '   Create New 2D Array
        OldRowUbound = UBound(ArrayNameToPreserve, 1)                                                       '   Save row Ubound of original array
        OldColumnUbound = UBound(ArrayNameToPreserve, 2)                                                    '   Save column Ubound of original array
'
        For NewRow = LBound(ArrayNameToPreserve, 1) To NewRowUbound                                         '   Loop through rows of original array
            For NewColumn = LBound(ArrayNameToPreserve, 2) To NewColumnUbound                               '       Loop through columns of original array
                If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then
                    NewArrayNameToPreserve(NewRow, NewColumn) = ArrayNameToPreserve(NewRow, NewColumn)      '               Append additional rows/columns to NewArrayNameToPreserve
                End If
            Next                                                                                            '       Loop back
        Next                                                                                                '   Loop back
'
        If IsArray(NewArrayNameToPreserve) Then ReDimPreserve = NewArrayNameToPreserve
    End If
End Function