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