Retranscription de données sur 2 classeurs différents

bonsoir à tous les internautes de ce forum,

je sollicite votre aide concernant un problème de retranscription de données.

je dispose de données sur un classeur (voir fichier joint) et mon but est de retranscrire ces données sur 1 classeur lorsque la mention dans la colonne D indique "Entrée" et à retranscrire ces même données sur un autre classeur lorsque la colonne D indique "Sortie".

je me suis inspiré d'un code trouvé sur un site internet et qui permet de retranscrire des données sur un seul tableau:

Private Sub CommandButton1_Click()
Dim Quest As Integer
Dim Repertoire As String
Dim FichDest As String
Dim FichSource As String
Dim NouvFeuil As String
Dim Trouve As Boolean
Dim IntWS As Integer
    Application.ScreenUpdating = False
    Quest = MsgBox("Etes-vous sûr de vouloir enregistrer la Feuille ?", vbYesNo + vbQuestion)
    If Quest = vbNo Then Exit Sub
    If Quest = vbYes Then
    Repertoire = ActiveWorkbook.Path & "\" 'changer le chemin ici
    FichDest = "T2.xls" 'changer le nom ici
    FichSource = ThisWorkbook.Name
        If ActiveSheet.Range("A1").Value <> vbNullString Then
        NouvFeuil = ActiveSheet.Range("A1").Value
        End If
    Workbooks.Open Repertoire & FichDest
    Windows(FichDest).Activate
    Trouve = False
        For IntWS = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(IntWS).Name = NouvFeuil Then
                Trouve = True
                Windows(FichSource).Activate
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest).Sheets(NouvFeuil).Range("B65000").End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
                Exit For
            End If
        Next IntWS
            If Trouve = False Then
                ActiveWorkbook.Sheets.Add , After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = NouvFeuil
                Windows(FichSource).Activate
                ActiveSheet.Range("B7:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest).Sheets(NouvFeuil).Range("B3")
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
            End If
        Application.DisplayAlerts = False
        Workbooks(FichDest).Save
        Workbooks(FichDest).Close

    Application.ScreenUpdating = True
    End If

End Sub

j'ai essayé de modifier ce code à ma façon (c'est à dire comme quelqu'un qui patauge complètement en langage VB... ) et à plusieurs reprises. mais rien ne marche. j'ai une "erreur d'exécution 13". (le fichier joint est en fin de message)

si quelqu'un saurait me venir en aide, ce serait vraiment super!!!!

le code que j'ai essayé de construire est le suivant.

merci d'avance

Alex

Private Sub CommandButton1_Click()
Dim Quest As Integer
Dim Repertoire As String
Dim FichDest1 As String
Dim FichDest2 As String
Dim FichSource As String
Dim NouvFeuil As String
Dim Trouve As Boolean
Dim IntWS As Integer
    Application.ScreenUpdating = False
    Quest = MsgBox("Etes-vous sûr de vouloir enregistrer la Feuille ?", vbYesNo + vbQuestion)
    If Quest = vbNo Then Exit Sub
    If Quest = vbYes Then
    Repertoire = ActiveWorkbook.Path & "\" 'changer le chemin ici
    FichDest1 = "ENTREE10.xls" 'changer le nom ici
    FichDest2 = "SORTIE10.xls" 'changer le nom ici
    FichSource = ThisWorkbook.Name
        If ActiveSheet.Range("A1").Value <> vbNullString Then
        NouvFeuil = ActiveSheet.Range("A1").Value
        End If

If ActiveSheet.Range("d8:d65000").Value = "Entrée" Then
    Workbooks.Open Repertoire & FichDest1
    Windows(FichDest1).Activate
    Trouve = False
        For IntWS = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(IntWS).Name = NouvFeuil Then
                Trouve = True
                Windows(FichSource).Activate
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest1).Sheets(NouvFeuil).Range("B65000").End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest1).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
                Exit For
            End If
        Next IntWS
            If Trouve = False Then
                ActiveWorkbook.Sheets.Add , After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = NouvFeuil
                Windows(FichSource).Activate
                ActiveSheet.Range("B7:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest1).Sheets(NouvFeuil).Range("B3")
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest1).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
            End If
        Application.DisplayAlerts = False
        Workbooks(FichDest1).Save
        Workbooks(FichDest1).Close

    Application.ScreenUpdating = True
    End If
End If

If ActiveSheet.Range("d8:d65000").Value = "Sortie" Then
    Workbooks.Open Repertoire & FichDest2
    Windows(FichDest2).Activate
    Trouve = False
        For IntWS = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(IntWS).Name = NouvFeuil Then
                Trouve = True
                Windows(FichSource).Activate
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest2).Sheets(NouvFeuil).Range("B65000").End(xlUp).Offset(1, 0)
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest2).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
                Exit For
            End If
        Next IntWS
            If Trouve = False Then
                ActiveWorkbook.Sheets.Add , After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = NouvFeuil
                Windows(FichSource).Activate
                ActiveSheet.Range("B7:F" & Range("B65000").End(xlUp).Row).Copy _
                Destination:=Workbooks(FichDest2).Sheets(NouvFeuil).Range("B3")
                Application.CutCopyMode = False
                ActiveSheet.Range("B8:F" & Range("B65000").End(xlUp).Row).ClearContents
                Windows(FichDest1).Activate
                Sheets(NouvFeuil).Rows.AutoFit
                Sheets(NouvFeuil).Columns.AutoFit
            End If
        Application.DisplayAlerts = False
        Workbooks(FichDest2).Save
        Workbooks(FichDest2).Close

    Application.ScreenUpdating = True
    End If

End Sub

https://www.excel-pratique.com/~files/doc2/IaZhDClasseur1.xls