Don't expect this to be fast as you wanted a many to many search. There might be something faster than Instr().
Sub Main()
Dim p$, fn$, i As Long, j As Long, r As Long, c As Integer
Dim a, b, e, rr As Range, cc As Range
Dim ws As Worksheet, o As Object, s$
Dim fso As Object 'New Scripting.FileSystemObject
'******************* INPUTS **********************************
p = ThisWorkbook.Path & "\" 'Parent folder
Set ws = Worksheets(1)
'******************* END INPUTS ******************************
'List of 4 digit numbers. 'e.g. SD/#7301/, SD/#0231/
Set rr = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
On Error GoTo EndSub
Application.DisplayAlerts = False
a = aFFs(p & "*.doc", , True)
If Not IsArray(a) Then Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
ReDim b(1 To Rows.Count, 1 To 4)
For Each e In a
Set o = GetObject(e)
s = o.Content
For Each cc In rr
i = InStr(s, "SD/#" & cc.Text & "/")
If i > 0 Then
j = j + 1
b(j, 1) = fso.GetFile(CStr(e)).Name
b(j, 2) = cc.Text
fn = fso.GetParentFolderName(CStr(e))
If Len(fn) > Len(p) Then b(j, 3) = Right(fn, Len(fn) - Len(p))
b(j, 4) = WorksheetFunction.Round(Len(s) / 65, 0)
End If
Next cc
o.Close False
Next e
Set fso = Nothing
If j = 0 Then Exit Sub
b = Application.Index(b, Evaluate("row(1:" & j & ")"), Application.Transpose([row(1:4)]))
ws.[B2].Resize(j, 4).Value = b
ws.UsedRange.Columns.AutoFit
EndSub:
Set fso = Nothing
Application.DisplayAlerts = True
End Sub
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant
Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long
If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.readall
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.readall
End If
a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function
Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function
Reply With Quote
Originally Posted by Kenneth Hobs
