Import données de plusieurs fichiers excel vers un fichier excel BDD

Private Sub cmdRecupereJanv_Click()
    Dim intFile As Integer
    Dim strWB As String
    Dim strFile As String
    Dim lgDerLig As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' Nom du classeur actuel
    strWB = ThisWorkbook.Name
    
    lgDerLig = 2
    
    ' Récupération du premier fichier dans le répertoire
    strFile = Dir(ThisWorkbook.Path & "\01\*.xls")
    
    ' Boucle du 1er au dernier classeur dans le répertoire
    Do While strFile <> ""
        ' Si le classeur n'est pas "BDD.xlsm"
        If strFile <> strWB Then
            ' Ouvrir le fichier
            Workbooks.Open ThisWorkbook.Path & "\01\" & strFile
            
            ' Sélectionner le 2me onglet
            ActiveWorkbook.Worksheets(3).Activate
            ' Copier la 2me ligne dans le classeur Total
            'Worksheets(3).Rows("2:2").Copy Destination:=Workbooks(strWB).Worksheets("Feuil1").Range("A" & lgDerLig)
            Workbooks(strWB).Worksheets("Janvier").Range("A" & lgDerLig) = Worksheets(3).Range("A17")
            Workbooks(strWB).Worksheets("Janvier").Range("B" & lgDerLig) = Worksheets(3).Range("A20")
            Workbooks(strWB).Worksheets("Janvier").Range("C" & lgDerLig) = Worksheets(3).Range("C33")
            Workbooks(strWB).Worksheets("Janvier").Range("D" & lgDerLig) = Worksheets(3).Range("E12")
            Workbooks(strWB).Worksheets("Janvier").Range("E" & lgDerLig) = Worksheets(3).Range("D2")
            
            lgDerLig = lgDerLig + 1
            
            ' Fermeture du classeur
            Workbooks(strFile).Close
        End If
        
        ' Classeur suivant
        strFile = Dir
    Loop
    
    MsgBox "Le traitement des fichiers est terminé.", vbInformation, "Traitement..."
        
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub