Global oShell As Object
Private FileList As Variant
Function GetFiles(ByVal Folder As Variant)
Dim File As Object
Dim Files As Object
Dim SubFolder As Object
Dim SubFolders As Object
If oShell Is Nothing Then Set oShell = CreateObject("Shell.Application")
Set Folder = oShell.Namespace(Folder)
Set Files = Folder.Items
Files.Filter 64, "*.xls;*.xlsx"
If VarType(FileList) = vbEmpty Then ReDim FileList(0)
For Each File In Files
Set FileList(UBound(FileList)) = File
ReDim Preserve FileList(UBound(FileList) + 1)
Next File
Set SubFolders = Folder.Items
SubFolders.Filter 32, "*"
For Each SubFolder In SubFolders
Call GetFiles(SubFolder.Path)
Next SubFolder
GetFiles = FileList
End Function
Sub FindChecks()
Dim c As Long
Dim Cell As Range
Dim Check As Range
Dim Checks As Object
Dim CheckRng As Range
Dim Data As Variant
Dim File As Variant
Dim Folder As Variant
Dim n As Long
Dim MainWks As Worksheet
Dim r As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim Wkb As Workbook
Dim Wks As Worksheet
Set MainWks = ThisWorkbook.Worksheets("Sheet1")
Set CheckRng = MainWks.Range("A1").CurrentRegion.Columns(1)
Set CheckRng = Intersect(CheckRng, CheckRng.Offset(1, 0))
If CheckRng Is Nothing Then Exit Sub
MainWks.UsedRange.Offset(1, 1).ClearContents
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Folder = .SelectedItems(1)
End With
FileList = Empty
FileList = GetFiles(Folder)
If UBound(FileList) = 0 Or VarType(FileList) = vbEmpty Then
MsgBox "No XLS or XLSX files were found in the folder """ & Folder & """ or it's Subfolders.", vbExclamation
Application.ScreenUpdating = True
Exit Sub
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Checks = Nothing
Set Checks = CreateObject("Scripting.Dictionary")
Checks.CompareMode = vbTextCompare
For Each Check In CheckRng.Cells
If Not Checks.Exists(Check.Value) Or Not Checks.Exists(Check.Text) Then
On Error Resume Next
Checks.Add Val(Check.Value), Check
Checks.Add Check.Text, Check
On Error GoTo 0
End If
Next Check
For n = 0 To UBound(FileList) - 1
DoEvents
' Check if folder zipped.
If FileList(n).Parent.Self.Type Like "*zipped*" Then
UnzipFolder FileList(n).Parent.Self.Path
Set Folder = oShell.Namespace(Environ("TEMP") & "\Unzip")
For Each File In Folder.Items
Set Wkb = Workbooks.Open(File.Path)
GoSub SearchWorksheets
Wkb.Close SaveChanges:=False
Next File
Else
Set Wkb = Workbooks.Open(FileList(n).Path)
GoSub SearchWorksheets
Wkb.Close SaveChanges:=False
End If
Next n
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub
SearchWorksheets:
For Each Wks In Wkb.Worksheets
Set RngBeg = Wks.Cells.Find("*", Wks.Cells(Rows.Count, Columns.Count), xlFormulas, xlPart, xlByColumns, xlNext, False, False, False)
If Not RngBeg Is Nothing Then
r = Wks.Cells.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious, False, False, False).Row
c = Wks.Cells.Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious, False, False, False).Column
Set RngEnd = Wks.Cells(r, c)
End If
If Not RngBeg Is Nothing And Not RngEnd Is Nothing Then
With Wks.Range(RngBeg, RngEnd)
If .Cells.Count = 1 Then
ReDim Data(1, 1)
Data(1, 1) = .Value
Else
Data = .Value
End If
End With
For r = 1 To UBound(Data, 1)
For c = 1 To UBound(Data, 2)
If Checks.Exists(Data(r, c)) Then
With Checks(Data(r, c)).Offset(0, 1)
Fields = Array(.Offset(0, 0) & Wkb.Name & "*", _
.Offset(0, 1) & FileList(n).Parent.Self.Path & "*", _
.Offset(0, 2) & Wks.Name & "*", _
.Offset(0, 3) & RngBeg.Offset(r - 1, c - 1).Address & "*")
.Resize(1, 4).Value = Fields
End With
End If
Next c
Next r
End If
Next Wks
Return
End Sub
Reply With Quote
