Sub CopyFilesWithNumberedIDs()
'--purpose is to read a list of ID numbers in worksheet then
' for each number find and copy all files in a specified folder
' that either:
' contain that number in the filename or
' have that number fall within a span of numbers specified
' by the filename
' any ID numbers that don't have corresponding files will be highlighted
'--requires reference to Microsoft Scripting Runtime library
Dim bMatchFound As Boolean, bSomeNotFound As Boolean
Dim dctFilesToCopy As Scripting.Dictionary
Dim dID As Double
Dim lNdx As Long, lLastRow As Long
Dim rIDs As Range, rCell As Range
Dim sSrcFolder As String, sTgtFolder As String, sFileName As String
Dim sFileNamePattern As String, sParsedNumber As String, sID As String
Dim vFileSpecMatches As Variant, vFilesNamesToCopy As Variant
Dim vSingleIDs As Variant, vSpansOfIDs As Variant, vKey As Variant
With ActiveSheet 'read inputs-modify to match actual range addresses
sSrcFolder = .Range("A2").Value ' c:\test\source\
sTgtFolder = .Range("A3").Value ' c:\test\matches\
sFileNamePattern = .Range("A4").Value ' *.pdf"
'--read list of numbered ids
lLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If lLastRow < 2 Then
MsgBox "No ID Numbers found."
GoTo ExitProc
End If
Set rIDs = .Range("B2:B" & lLastRow)
'--get list of all files in source folder meeting pattern criterion
vFileSpecMatches = vGetFileNames(sFileSpec:=sSrcFolder & sFileNamePattern)
If IsNull(vFileSpecMatches) Then
MsgBox "No matches were found for: " & vbCr _
& sSrcFolder & sFileNamePattern
GoTo ExitProc
End If
End With
Set dctFilesToCopy = New Scripting.Dictionary
'--parse filenames to resize and fill two arrays ByRef
' vSingleIDs: single IDs associated with a file
' vSpansOfIDs: spans of ID numbers associated with a file
' first dim of arrays is filename, second dim is ID Code
ReDim vSingleIDs(1 To 2, 1 To 1)
ReDim vSpansOfIDs(1 To 2, 1 To 1)
Call ParseIDs(vFileNames:=vFileSpecMatches, _
vSingleIDs:=vSingleIDs, vSpansOfIDs:=vSpansOfIDs)
For Each rCell In rIDs
bMatchFound = False 'reset
sID = rCell.Value
If Not IsNumeric(sID) Then
MsgBox sID & " is an invalid ID number", vbCritical, _
"Process stopped"
GoTo ExitProc
End If
dID = CDbl(sID)
'--check for exact matches in single ID list
If Not IsNull(vSingleIDs) Then
For lNdx = 1 To UBound(vSingleIDs, 2)
If dID = vSingleIDs(2, lNdx) Then
'--store matched filename in list to be copied
bMatchFound = True
sFileName = CStr(vSingleIDs(1, lNdx))
If Not dctFilesToCopy.Exists(sFileName) Then
dctFilesToCopy.Add sFileName, 1
End If
End If
Next lNdx
End If
'--check for matches within span in vSpansOfIDs list
If Not IsNull(vSpansOfIDs) Then
For lNdx = 1 To UBound(vSpansOfIDs, 2)
If dID >= vSpansOfIDs(2, lNdx) And _
dID <= vSpansOfIDs(3, lNdx) Then
'--store matched filename in list to be copied
bMatchFound = True
sFileName = CStr(vSpansOfIDs(1, lNdx))
If Not dctFilesToCopy.Exists(sFileName) Then
dctFilesToCopy.Add sFileName, 1
End If
End If
Next lNdx
End If
If Not bMatchFound Then
rCell.Interior.Color = vbRed
bSomeNotFound = True
End If
Next rCell
'--copy all files stored in dictionary
For Each vKey In dctFilesToCopy.Keys
sFileName = CStr(vKey)
FileCopy sSrcFolder & sFileName, sTgtFolder & sFileName
Next vKey
If bSomeNotFound Then MsgBox _
"Some IDs did not have matching files found. " & _
vbCr & "These were highlighted for your reference."
ExitProc:
Set dctFilesToCopy = Nothing
End Sub
Private Sub ParseIDs(ByVal vFileNames As Variant, ByRef vSingleIDs As Variant, _
ByRef vSpansOfIDs As Variant)
'--takes array of filenames as input
'--passes back ByRef to calling procedure two 2D arrays
' with pairs of filename and ID_Code
'--ID_Code is either single ID number or span of ID numbers
'The format of the pdfs can be any of these:
' 12345.pdf
' 12345-12348.pdf
' 12345(1).pdf
' 12345_001.pdf
Dim lNdxSource As Long, lNdxSingle As Long, lNdxSpan As Long
Dim dMin As Double, dMax As Double, dID As Double
Dim sFileName As String, sID_Code As String
Dim vReturn As Variant
ReDim vSingleIDs(1 To 2, 1 To UBound(vFileNames))
ReDim vSpansOfIDs(1 To 3, 1 To UBound(vFileNames))
For lNdxSource = 1 To UBound(vFileNames)
sFileName = vFileNames(lNdxSource)
If InStr(1, sFileName, "-") = 0 Then
'--ID Code is single ID number
dID = dGetVal(sFileName)
If dID >= 0 Then
lNdxSingle = 1 + lNdxSingle
vSingleIDs(1, lNdxSingle) = sFileName
vSingleIDs(2, lNdxSingle) = dID
End If
Else
'--ID_Code is span of numbers
dMin = dGetVal(sFileName)
dMax = dGetVal(Mid(sFileName, InStr(1, sFileName, "-") + 1))
If dMin >= 0 And dMax >= dMin Then
lNdxSpan = 1 + lNdxSpan
vSpansOfIDs(1, lNdxSpan) = sFileName
vSpansOfIDs(2, lNdxSpan) = dMin
vSpansOfIDs(3, lNdxSpan) = dMax
End If
End If
Next lNdxSource
'--resize arrays
If lNdxSingle Then
ReDim Preserve vSingleIDs(1 To 2, 1 To lNdxSingle)
Else
vSingleIDs = Null
End If
If lNdxSpan Then
ReDim Preserve vSpansOfIDs(1 To 3, 1 To lNdxSpan)
Else
vSpansOfIDs = Null
End If
End Sub
Private Function vGetFileNames(ByVal sFileSpec As String) As Variant
'--returns array of filenames matching sFileSpec pattern
' if no matches are found, returns Null
Dim lCount As Long, lUbound As Long
Dim sFileName As String
Dim vReturn As Variant
'--used to limit the frequency of redim preserve calls
Const lREDIM_FREQ = 1000
ReDim vReturn(1 To lREDIM_FREQ)
sFileName = Dir(sFileSpec)
If Len(sFileName) = 0 Then
vReturn = Null
Else
While sFileName <> ""
lCount = lCount + 1
'--resize array if needed
If (lCount Mod lREDIM_FREQ) = 0 Then
ReDim Preserve vReturn(1 To UBound(vReturn) + lREDIM_FREQ)
End If
'--add to array
vReturn(lCount) = sFileName
sFileName = Dir()
Wend
ReDim Preserve vReturn(1 To lCount)
End If
vGetFileNames = vReturn
End Function
Private Function dGetVal(sInput As String) As Double
'--evaluates each character of sInput from left to right
' until character other than 0-9 is found.
' returns integer value of those numeric characters found
' or -1 if the first character is not 0-9 or
' resulting number exceeds 15 digits
Dim lPos As Long
Dim sHead As String, sChar As String
For lPos = 1 To Len(sInput)
sChar = Mid(sInput, lPos, 1)
If sChar Like "[0-9]" Then
sHead = sHead & sChar
Else
Exit For
End If
Next
If Len(sHead) = 0 Or Len(sHead) > 15 Then
dGetVal = -1
Else
dGetVal = CDbl(sHead)
End If
End Function
