Sub ult100()
ActiveWorkbook.Sheets(1).Cells.Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'dimension variables
Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet
Dim ws1 As Worksheet, Ws2 As Worksheet, i, ii As Long, Pos As Long
Dim Folder As String, File As String, Path As String
'folder to loop through
Folder = "C:\" 'change to suit
'set destination info
Set wsDest1 = ActiveWorkbook.Sheets(1) '<<== is this correct?
'Start FileSearch
With Application.FileSearch
.LookIn = Folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
Pos = InStrRev(.FoundFiles(i), "\")
File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos)
Path = Left(.FoundFiles(i), Pos)
'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(File) Then
Set wb = Workbooks(File)
Else
Set wb = Workbooks.Open(Path & File)
End If
'set worksheets to copy data from
Set ws1 = wb.Sheets("weekly")
'copy data
For ii = 1 To ws1.Range("c" & Rows.Count).End(xlUp).Row
If UCase(ws1.Cells(ii, "c")) = "ULT100" Then
wsDest1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4) = ws1.Cells(ii, "a").Resize(, 4).Value
End If
Next
wb.Close
Next i
End If
End With
Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing
Set Ws2 = Nothing: Set wb = Nothing
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function