Modification d'un code VBA

[Shpountz]

Bonjour à Tous

Il y a quelque temps BOUGLA972 m'avait donné le code suivant

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

Je souhaiterai pouvoir apporter les modifications suivantes

- Suppressions de 101-R1 et modification en 1, 2, 3 etc...
- Intégrations des manquants jusqu'à N° 20
- Tri de 1 a 20

Je joins le fichier MAIS attention ne pas lancer la macro car elle effacera les résultats souhaités
Les résultats sont en ligne 131 sur les onglets

Merci à tous
Amicalement
François

 

[mapomme]

Bonjour Shpountz,

Un essai dans le fichier joint (les onglets sont triés par la macro).

 

[Shpountz]

Bonjour mapomme

un grand merci pour votre aide.
Cela fonctionne parfaitement.

J'ai encore une petite question.
Je dois inclure cette action dans un autre classeur.
Dans celui-ci les onglets se créent automatiquement avec leur noms tous les jours.
Les noms correspondent à ceux créer par "Algos" comment puis je faire pour inclure votre macro sur mon classeur ?
J'ai recopié votre module dans mon classeur mais quand je le lance ce la me dit "erreur d'exécution "9", l'indice n"appartient pas à la sélection.
With ThisWorkbook.Worksheets(clef) 'écriture du tableau res sur l'onglet clef

Un grand merci pour votre aide
Amicalement
François

 

[mapomme]

Re,

Je ne comprends pas bien. Un fichier exemple avec la vraie structure et comportant l'erreur citée serait le bienvenu .

 

[Shpountz]

Bonjour mapomme

Merci pour votre aide;
Ci-joint un fichier

Amicalement
François

 

[Shpountz]

Bonjour mapomme

j'ai cherché de mon coté mais mes connaissances en vba sont encore très limite...
Merci d'avance pour votre aide

Amicalement
François