XL 2016 Modifier code VBA pour traitement de données

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

luke3300

XLDnaute Impliqué
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?

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 😀
 
Dernière édition:
Bonjour le forum,

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

Code:
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.
 
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
 
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.
 

Pièces jointes

  • 2016-10-19_07-32-44.jpg
    2016-10-19_07-32-44.jpg
    255.5 KB · Affichages: 55
  • Test.xlsm
    Test.xlsm
    198.9 KB · Affichages: 50
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)
 
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.😉
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
45
Réponses
2
Affichages
371
Réponses
4
Affichages
457
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
481
Réponses
4
Affichages
332
Réponses
3
Affichages
216
Réponses
3
Affichages
569
Retour