VBA excel, How to select files from a folder and apply code to all?

Question

In this code:

1. How do I open a folder containing several files of the same structure and then apply the code automatically?.
2. The code for 3 files is shown but it is required for all the files in the folder, how can I avoid copying the same thing?.
3. Al correr el código demora en llenar cada celda

Sub COPYCELL()

Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet

strFirstFile = "E:\2020\Informes de Tutoría\18 semana\F3 S18 1A Isabel.xls"
strSecondFile = "D:\Nueva carpeta\4 Ficha-directivos-Seguimiento-Tutoria-Semana 16.xls"

Set wbk1 = Workbooks.Open(strFirstFile)
Set ws1 = wbk1.Sheets("F3")

Set wbk2 = Workbooks.Open(strSecondFile)
Set ws2 = wbk2.Sheets("F3")

With ws2
    .Range("g7").Value = ws1.Range("o34").Value
    .Range("m7").Value = ws1.Range("p34").Value
    .Range("q7").Value = ws1.Range("t33").Value
    .Range("T7").Value = ws1.Range("U33").Value
    .Range("V7").Value = ws1.Range("W33").Value
    .Range("W7").Value = ws1.Range("X38").Value
    .Range("X7").Value = ws1.Range("Z38").Value
   End With
    Workbooks(wbk1.Name).Close savechanges:=False

'Archivo1
Dim wbk11 As Workbook, wbk21 As Workbook
Dim ws11 As Worksheet, ws21 As Worksheet

strFirstFile = "E:\2020\Informes de Tutoría\18 semana\F3 S18 1B Jaime.xls"
strSecondFile = "D:\Nueva carpeta\4 Ficha-directivos-Seguimiento-Tutoria-Semana 16.xls"

Set wbk11 = Workbooks.Open(strFirstFile)
Set ws11 = wbk11.Sheets("F3")

Set wbk21 = Workbooks.Open(strSecondFile)
Set ws21 = wbk21.Sheets("F3")

With ws21

    .Range("g8").Value = ws11.Range("o34").Value
    .Range("m8").Value = ws11.Range("p34").Value
    .Range("q8").Value = ws11.Range("t33").Value
    .Range("T8").Value = ws11.Range("U33").Value
    .Range("V8").Value = ws11.Range("W33").Value
    .Range("W8").Value = ws11.Range("X38").Value
    .Range("X8").Value = ws11.Range("Z38").Value
    
End With
    Workbooks(wbk11.Name).Close savechanges:=False

'Archivo2
Dim wbk12 As Workbook, wbk22 As Workbook
Dim ws12 As Worksheet, ws22 As Worksheet

strFirstFile = "E:\2020\Informes de Tutoría\18 semana\F3 S18 1C David.xls"
strSecondFile = "D:\Nueva carpeta\4 Ficha-directivos-Seguimiento-Tutoria-Semana 16.xls"

Set wbk12 = Workbooks.Open(strFirstFile)
Set ws12 = wbk12.Sheets("F3")

Set wbk22 = Workbooks.Open(strSecondFile)
Set ws22 = wbk22.Sheets("F3")

With ws22

    .Range("g9").Value = ws12.Range("o34").Value
    .Range("m9").Value = ws12.Range("p34").Value
    .Range("q9").Value = ws12.Range("t33").Value
    .Range("T9").Value = ws12.Range("U33").Value
    .Range("V9").Value = ws12.Range("W33").Value
    .Range("W9").Value = ws12.Range("X38").Value
    .Range("X9").Value = ws12.Range("Z38").Value
    
End With
    Workbooks(wbk12.Name).Close savechanges:=False

End Sub

Answer 1

Please try this code. However, before you do I suggest you read all the comments and try to understand its logic. Good luck.

Sub LoopThroughFolder()
    ' 078
    
    ' path name ends on a path separator
    Const PathName  As String = "E:\2020\Informes de Tutoría\18 semana\"
    
    Dim Fn          As String           ' File name
    Dim WbS         As Workbook         ' Source: Workbook
    Dim WsS         As Worksheet        ' Source: worksheet
    Dim BooksCount  As Integer          ' count of how many workbooks are open
    Dim WsT         As Worksheet        ' Target sheet (in ThisWorkbook)
    Dim Rt          As Long             ' Row: target
    
    Set WsT = Worksheets("F3")          ' define the sheet by name
    Fn = Dir(PathName)                  ' pick the first file in the folder
    Rt = 7                              ' first target row
    BooksCount = Workbooks.Count        ' count of how many workbooks are open
    Application.ScreenUpdating = False  ' speeds up the procedure
    
    Do While Len(Fn)                    ' loop if there is a file name
        Application.StatusBar = "Now processing " & Fn     ' show progress
        ' test if the file name meets your requirements
        If InStr(1, Fn, ".xl", vbTextCompare) And _
           (Fn <> ThisWorkbook.Name) Then
            Set WbS = Workbooks.Open(PathName & Fn)
            On Error Resume Next        ' in case the worksheet doesn't exist
            Set WsS = WbS.Worksheets("F3")
            If Err.Number = 0 Then
                With WsS
                    ' using 'Copy' will also transfer cell formatting
                    ' the alternative requires you  to apply formatting to WsT
                    ' WsT.Cells(Rt, "G").Value = .Range("O34").Value
                    .Range("O34").Copy Destination:=WsT.Cells(Rt, "G")
                    .Range("P34").Copy Destination:=WsT.Cells(Rt, "M")
                    .Range("T33").Copy Destination:=WsT.Cells(Rt, "Q")
                    .Range("U33").Copy Destination:=WsT.Cells(Rt, "T")
                    .Range("W33").Copy Destination:=WsT.Cells(Rt, "V")
                    .Range("X38").Copy Destination:=WsT.Cells(Rt, "W")
                    .Range("Z38").Copy Destination:=WsT.Cells(Rt, "X")
                End With
                Rt = Rt + 1
            End If
            
            WbS.Close SaveChanges:=False
            Do While Workbooks.Count > BooksCount
                DoEvents                        ' wait for WbS to close
            Loop
        End If
        Fn = Dir                                ' get the next file name
    Loop
    With Application
        .StatusBar = "Done"                     ' show progress
        .ScreenUpdating = True                  ' show final result
    End With
End Sub

Note that I tested the looping bit but not the transfer of data which remains largely the way you had it.