Codes for looping thru all file when matches found

Need to loop thru all files in a folder, then move data to a master spreadsheet when criteria matches.

It is not working as expected. But i can't figure out way. I am guessing it has something to do with where " Set WBD = Workbooks.Open(Filename:=thisfile) " needs to be.

Thanks.

Sub Check()
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
 
  Dim WBN As Workbook, WBD As Workbook
  Dim WSN As Worksheet, WSD As Worksheet
  Dim str As String
 
  
 
Dim rng As Range
 
fp = "C:\Users\XYZK\Desktop\Load Without Losses\"
 
 
 
file = Dir(fp & "*.csv")
 
ChDir (fp)
 
 
While (file <> "")
      If InStr(file, "DAY") > 0 Then
     
      
      Set WBN = Workbooks.Open(Filename:=file)
     
    
      
      str = "~*"
   
Set rng = WBN.Sheets(1).Cells(5, 1).EntireRow.Find(str, LookIn:=xlValues)
 
If Not rng Is Nothing Then
 
    rng.EntireColumn.Delete
   
    End If
   
 
lr = WBN.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
 
col = Application.WorksheetFunction.Match("status", WBN.Sheets(1).Rows(5), 0)
 
 
thisfile = ThisWorkbook.Sheets("summary").Range("b2")
   
    Set WBD = Workbooks.Open(Filename:=thisfile)
   
    Set WSD = WBD.Sheets("act wo losses (MSRS)")
   
    
 
For i = 1 To lr
 
       If WBN.Sheets(1).Cells(i, col).Value = "checks" Then
      
        Set Data = Union(WBN.Sheets(1).Cells(i, 3), WBN.Sheets(1).Cells(i, col).Offset(0, 3).Resize(, 24))
      
        Data.Copy
       
        lastrow = WSD.Cells(Rows.Count, 2).End(xlUp).Row
       
        WSD.Cells(lastrow, 1).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
       
        
        
        
        
        
        End If
       
              
     
     
        
Next i
 
    WSD.Activate
   
    
    WBN.Close SAVECHANGEs:=False
   
    
      
      Exit Sub
     
      
      End If
 
Wend