Modification d'un code VBA

Sub TransfertLignes()
Dim T1 As Variant, T2 As Variant
Dim D_Lig As Long
Dim DerCol As Byte
Dim SDerCol As String, Let_Col As String
Dim i As Integer, l As Long, Nbcol As Integer
Dim TrouveOnglet As Boolean
Dim DicoEntetes As Object, Dico As Object
Dim Ws As Worksheet, Ws1 As Worksheet
Dim clé, LigDico, c
Dim Pos As Byte
Dim NbLigTab As Long

If MsgBox("Souhaitez-vous transférer le tableau ?", _
vbInformation + vbYesNo, "Transfert") = vbNo Then Exit Sub

Application.ScreenUpdating = False

'Tbl_Collaborateurs**********************************************************************
With ThisWorkbook.Sheets("Algos")
    D_Lig = .Range("A65536").End(xlUp).Row
    'On récupère le num de la derniere colonne pour exploitation dans tableau
    DerCol = .Range("A1").End(xlToRight).Column
    SDerCol = .Range("A1").End(xlToRight).Address: Let_Col = Mid(SDerCol, 2, InStr(2, SDerCol, "$") - 2)
    T1 = .Range("A1:" & Let_Col & D_Lig).Value
End With

Set Dico = CreateObject("Scripting.Dictionary")
Set DicoEntetes = CreateObject("Scripting.Dictionary")

For l = 1 To UBound(T1)
    If l = 1 Then
        For DerCol = 1 To UBound(T1, 2)
            DicoEntetes(T1(1, DerCol)) = ""
        Next DerCol
    Else
        Dico(Right(T1(l, 1), 2) & "C" & Left(T1(l, 1), 1)) = l
    End If
Next l

'Boucle sur le Dico
For Each c In Dico.keys
    TrouveOnglet = False
    'Boucle sur les onglets pour savoir pour les créer si besoin
    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "Algos" Then
            If Ws.Name = c Then TrouveOnglet = True
        End If
    Next Ws
    'Si on a pas trouvé l'onglet alors on le crée
    If Not TrouveOnglet Then
        Set Ws1 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        Ws1.Name = c
    End If
   
    'On redimensionne T2
    ReDim T2(1 To DicoEntetes.Count, 0)
   
    'Boucle sur le T1 => Algos
    For l = 2 To UBound(T1)
        Pos = InStrRev(T1(l, 1), "R")
        If Mid(T1(l, 1), Pos) & "C" & Left(T1(l, 1), 1) = c Then
            ReDim Preserve T2(1 To DicoEntetes.Count, 1 To UBound(T2, 2) + 1)
            For Nbcol = 1 To UBound(T1, 2)
                T2(Nbcol, UBound(T2, 2)) = T1(l, Nbcol)
            Next Nbcol
        End If
    Next l
   
    With ThisWorkbook.Sheets(c)
        'Transfert DicoEntetes
        .[A131].Resize(, DicoEntetes.Count) = DicoEntetes.keys
        'Transfert du T2 dans l'onglet c
        .[A132].Resize(UBound(T2, 2), UBound(T2, 1)).Value = Application.Transpose(T2)
       
    End With
Next c

ThisWorkbook.Sheets("Accueil").Activate

Set Dico = Nothing
Set DicoEntetes = Nothing
Set Ws1 = Nothing

Application.ScreenUpdating = True

MsgBox "Les transferts ont été réalisés !", vbInformation

End Sub