excel 2003 open all excel in a specific folder.

Hi to everyone.
Mary Cristmas and a happy new year.

I want to open all sheets in all excel in a specific folder and write the sheet name in the first column and copy
from all sheets a specific range (From B2 To B6) and paste it in my excel files.

Wright now i am able to write in my excel all the sheets name but i can not make a copy paste the B2:B6 range
from all the sheets.

My code so far is this.....

Sub SrchForFiles()
    Dim i As Long
    Dim Selected_Folder As String
        
    'Åëåí÷ïò áí ôï sheet õðÜñ÷åé
    For Each sh In Sheets
        If sh.Name = "Collect_Data" Then
            Application.DisplayAlerts = False
            Worksheets("Collect_Data").Delete
            Application.DisplayAlerts = True
        End If
    Next sh
    
    'Äçìéïõñãåßá ôïõ íÝïõ öýëëïõ
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Collect_Data"
    
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        Selected_Folder = .SelectedItems(1)
    End With
    With Application.FileSearch
        .NewSearch
        .LookIn = Selected_Folder
        .SearchSubFolders = True
        .Filename = "xls"
        If .Execute() > 0 Then
            ReDim XLSFind(.FoundFiles.Count)
            For i = 1 To .FoundFiles.Count
                If CBool(Len(Dir(.FoundFiles(i)))) Then
                    Call OpenExcelFile(.FoundFiles(i))
                End If
            Next i
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Sub OpenExcelFile(PathFolderName)
    Dim i As Long, j As Long, ws As Worksheet
    Dim iLastRowFS As Integer
    Dim objExcel As Object, objWorkbook As Object
    Set objExcel = CreateObject("Excel.Application")
    Set objWorkbook = objExcel.Workbooks.Open(PathFolderName)
    objExcel.Visible = True
    i = 2
        For Each ws In objWorkbook.Worksheets
            Cells("1", i).NumberFormat = "@"
            Cells("1", i).Value = CStr(ws.Name)
            ''''Here a want also to copy the B2:B6 columns to the Collect_Data Sheet.
            i = i + 1
        Next ws
    objWorkbook.Close False 'savechanges:=false
    Set objExcel = Nothing
    Set objWorkbook = Nothing
End Sub

Thanks and regards.