XL 2016 Modifier code VBA pour traitement de données

[luke3300]

Bonjour à tous,

Je profite d'un jour de congé pour améliorer un fichier que le forum m'avait aidé à créer.
Dans le code ci-dessous, j'aimerais enlever le fait que les données de la 3ème colonne n'aient plus de lettre devant leur nombre parce qu'actuellement, lorsque les données sont des nombres tels que 801, 999, S704, etc ... le code ne laissent que le derniers chiffre. J'aimerais qu'il laisse l'intitulé en entier.
Qui peut me dire ce que je dois enlever/modifier dans ce code?

Sub Titulariat()
'
' Configure le DL - Racourci ctrl + k
'
Application.ScreenUpdating = False

    Range("E:K,C:C").Delete
    Range("F25").Select
    Dim c As Range, f As Worksheet, d As Object
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 1
    Set f = Worksheets("DL") 'Feuil3
    f.Activate
    With f
        '.Rows ("1:" & .Columns(1).Find("Ancien NoTourn", LookAt:=xlPart).Row - 1).Delete Shift:=xlUp à enlever car pas de lignes à supprimer au-dessus!
        For Each c In .Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Address)
            If c.Value Like "Reg" & "*" Then
                c = Mid(c, 5) * 1
            End If
            c.Offset(, 2) = Mid(c.Offset(, 2), 2) * 1
        Next
        f.UsedRange.Sort key1:=Columns(3), order1:=1, key2:=Columns(1), order2:=1, Header:=xlYes

        For a = 2 To .UsedRange.Rows.Count
            If Not d.exists(.Cells(a, 3).Value) Then
                d.Item(.Cells(a, 3).Value) = ""
            Else
                If Not d.Item(.Cells(a, 3).Value) Like "*" & .Cells(a, 1) & "*" Then
                    d.Item(.Cells(a, 3).Value) = d.Item(.Cells(a, 3).Value) & "/" & .Cells(a, 1)

                End If
            End If
        Next

        With .Cells(1, 5).Resize(, d.Count)
            .Value = d.keys
            .Font.Bold = True
        End With
        .Cells(2, 5).Resize(, d.Count) = d.items
        For a = 5 To .Cells(1, Columns.Count).End(xlToLeft).Column
            b = Split(.Cells(2, a), "/")
            For e = 3 To UBound(b) + 3
                .Cells(e, a) = b(e - 3)
            Next e
            Range(.Cells(2, a), .Cells(3, a)).Delete Shift:=xlUp
        Next a
        .Cells(1, 5).CurrentRegion.Offset(1, 0).Copy
    End With
    Sheets("Nouveau G").Activate
        Range("f10").PasteSpecial Paste:=xlValues
    Set d = Nothing
    Set f = Nothing
    Sheets("DL").Select
    Columns("E:GV").Select
    Selection.ColumnWidth = 3.86
    Range("E1:GV1000").Select
    Selection.NumberFormat = "General"
    Range("D1").Select

End Sub

Merci d'avance et bon appétit 😀

 

[luke3300]

Bonjour le forum,

Je pense que la réponse doit se trouver dans cette partie du code mais où?

Dim c As Range, f As Worksheet, d As Object
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 1
    Set f = Worksheets("DL") 'Feuil3
    f.Activate
    With f
        '.Rows ("1:" & .Columns(1).Find("Ancien NoTourn", LookAt:=xlPart).Row - 1).Delete Shift:=xlUp à enlever car pas de lignes à supprimer au-dessus!
        For Each c In .Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Address)
            If c.Value Like "Reg" & "*" Then
                c = Mid(c, 5) * 1
            End If
            c.Offset(, 2) = Mid(c.Offset(, 2), 2) * 1
        Next
        f.UsedRange.Sort key1:=Columns(3), order1:=1, key2:=Columns(1), order2:=1, Header:=xlYes

        For a = 2 To .UsedRange.Rows.Count
            If Not d.exists(.Cells(a, 3).Value) Then
                d.Item(.Cells(a, 3).Value) = ""
            Else
                If Not d.Item(.Cells(a, 3).Value) Like "*" & .Cells(a, 1) & "*" Then
                    d.Item(.Cells(a, 3).Value) = d.Item(.Cells(a, 3).Value) & "/" & .Cells(a, 1)

                End If
            End If
        Next

J'ai testé en mettant par exemple un "2" à la place des "1" en ligne 10 et 12 mais nada 🙁
Merci d'avance pour votre aide et bon mercredi à tous.

 

[Staple1600]

Bonjour à tous

luke3300

pour améliorer un fichier que le forum m'avait aidé à créer.

L'est où, le fichier?
Sur ton disque dur?
Ce qui est très utile pour faire nos tests sur nos disques durs...

A vue de nez et sans pouvoir tester, je dirai qu'ici on ne prends pas l'intitulé entier
c = Mid(c, 5) * 1
End If
c.Offset(, 2) = Mid(c.Offset(, 2), 2) * 1

 

[luke3300]

Re le forum, Staple1600,

Voilà j'ai fais un fichier test dans lequel il suffit de bien regarder les données en colonne A et D avant de cliquer sur le bouton "synthèse des données". Toutes les données de la colonne A et D sont composées de nombres à 1, 2, 3 ou 4 chiffres (dans l'exemple 3). Et pour certaines, c'est avec un "S" devant (exemple ici S703). J'aimerais que quand la synthèse se fait, les intitulés restent les mêmes qu'avant la synthèse.

 

[Staple1600]

Re

Très drôle de joindre un fichier avec un mot de passe sur le projet VBA🙄😵

 

[luke3300]

Oups ... voici déprotégé 😉

 

[Staple1600]

Re

Il trop tard pour moi, je file sous la douche
A mes petits camarades de jeux de prendre le relais (ou pas)

NB: La prochaine fois, tu joindras directement un fichier sans mot de passe.
(qui d'ailleurs ne sert à rien, puisque on peut le supprimer mais ceci est une autre histoire)

 

[luke3300]

Re,

Merci quand même de t'être penché sur mon problème Staple1600 🙂
Désolé pour le mot de passe, j'ai dû adapter mon fichier que j'utilise pour pouvoir mettre un fichier test et j'ai complètement zappé qu'il était protégé 😕
Je suis obligé de le faire car nous sommes plusieurs à utiliser ce fichier. Le protéger est la seule manière pour moi que l'on ne touche pas (volontairement ou par erreur) à ce qui est fait.
Bonne journée.😉

 

[Dranreb]

Bonjour.
À priori il suffit de supprimer l'instruction :
' c.Offset(, 2) = Mid(c.Offset(, 2), 2) * 1

 

[luke3300]

Bonjour Dranreb,

Super! 😀 C'est exactement ça. Je ne savais pas quelle ligne enlever ...

Merci beaucoup pour ton aide et bon après-midi.