Cycle through all excel files in folder, compare and copy rows based on list

Thank you experts in advance for your expertise and assistance. I need a macro that can cycle through all excel files in a specified directory. Once opened look on worksheet “Current RPM” in column A starting row 2 and compare it to worksheet “ListofSheets” column A of the active workbook. On the worksheet "ListOfSheets" in the active workbook, it will vary between 25 to 40 items. There will be between 3,000 to 4,000 rows from columns A to CB for each opened excel file in the specified directory. There will only be one unique ID listed in column A on each respective worksheet and no duplicates. There will be several rows (somewhere between 25 and 40) copied from each opened file. Once found, the rows are to be copied from each opened workbook to a new sheet named “Current Projects” in the active workbook pasting the data to column B because I’d like the filenames to be listed in column A. The data will have to be appended as each new set of rows will be added as you go until all files have been opened and applicable rows copied and the files closed. The number of files in the specified directory may be variable. Thanks again for any assistance that you are able to provide.

I've attached the Sample Data. Thanks for your reply. The final results are on the Current Projects worksheet.

This starter demonstration must be pasted to the Current Projects worksheet module :

PHP Code: 

Sub Demo1()
    Const E = ".xlsx"
      Dim F$, P$, R&, W$, L&
          F = "=ISNUMBER(MATCH(A2," &[ListOfSheets!A1].CurrentRegion.Address(External:=True) & ",0))"
          P = ThisWorkbook.Path & Application.PathSeparator
          Me.UsedRange.Offset(1).Clear
          R = 2
          W = Dir(P & "*" & E)
    While W > ""
        With GetObject(P & W).Sheets("Current RPM").[A1].CurrentRegion
           .Range("CD2").Formula = F
           .AdvancedFilter xlFilterInPlace, .Range("CD1:CD2")
           L = Application.Subtotal(103, .Columns(1)) - 1
        If L Then
           .Offset(1).Copy Cells(R, 2)
            Cells(R, 1).Resize(L).Value2 = Replace(W, E, "")
            R = R + L
        End If
           .Parent.Parent.Close False
        End With
          W = Dir
    Wend
End Sub 


Do you like it ? So thanks to click on bottom left star icon « ★ Add Reputation » !

Thanks a million Marc, I'm able to use the code that you provided and it works perfectly!!!