Formatage automatique de données

Bonjour à toutes et à tous,

Je me permets de vous sollicitez car après avoir passé beaucoup de temps sur le problème, je ne suis pas capable de le résoudre et le temps me manque... J'ai des notions en VBA mais là ça me dépasse totalement et comme j'ai un fichier qui contient 2000 produits (donc impossible de le faire manuellement), je ne sais plus quoi faire.

Mon problème est le suivant :

J'ai un fichier qui me donne les tailles disponibles pour chacun des produits comme dans l'exemple ci-dessous :

• > Ceci représente les tailles disponible pour 1 produit !
• > Les lettres peuvent aller de "a" jusqu'à "i" et les chiffres de "65" jusqu'à "105"

A 70

A 75

A 80

B 65

B 70

B 75

B 80

B 85

C 65

C 70

C 75

C 80

Afin de pouvoir les intégrer dans un document indesign, je dois changer le format pour que celui-ci soit comme ci-dessous

60

65BCDE

70ABCDEF

75ABCEDEF

80ABCDE

85BC

90

95

100

105

En gros, il faut rechercher s'il y a le chiffre 60, y attacher toutes les lettres qui existe pour 60 et les ajouter à la suite dans le bon ordre, puis faire la même chose jusqu'à 105.

Je vais joindre le fichier qui reprend l'exemple que je viens d'expliquer.

Je ne sais pas si c'est possible et le niveau de complexité de mon problème mais de mon côté, ca me semble impossible.

Merci mille fois d'avance pour votre aide

Excellente soirée !

Thibault

Bonjour,

Une piste avec un dictionnaire. Le tableau de résultat souhaités que tu as mis en exemple ne correspond absolument pas au résultat obtenu avec le tableau de valeurs brutes !

Mon code fait ce que tu demande si j'ai bien tout compris :

Sub Test()

    Dim Plage As Range
    Dim Cel As Range
    Dim Dico As Object
    Dim Cle As Variant
    Dim I As Integer

    Set Dico = CreateObject("Scripting.Dictionary")

    'défini la plage de B2 à Bx sur la feuille active
    With ActiveSheet: Set Plage = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With

    'boucle sur la plage et concatène les lettres
    For Each Cel In Plage: Dico(Cel.Value) = Dico(Cel.Value) & Cel.Offset(, -1).Value: Next Cel

    'rajoute la clé en préfixe
    For Each Cle In Dico.Keys: Dico(Cle) = Cle & Dico(Cle): Next Cle

    'inscrit les résultats en colonne C à partir de C2 de la feuille active
    For Each Cle In Dico.Keys

        I = I + 1
        Cells(I + 1, 3).Value = Dico(Cle)

    Next Cle

End Sub

Bonjour à tous,

Ah, je suis en retard sur Theze

Je poste quand même...

Je trie ton tableau avant, pour simplifier, à voir si c'est rédhibitoire. L'utilisation d'un dico comme Theze permet de s'en passer.

Cliquer en D1

eric

Bonjour à tous les deux,

Je viens de tester et ça fonctionne merveilleusement bien !!!

Vraiment merci beaucoup, vous venez de me rendre un énorme service.

Et désolé si mon exemple n'était pas parfait mais j'ai essayé de faire au mieux

Je vais analyser les codes afin de comprendre comment faire la prochaine fois.

Encore merci merci merci.

Excellente soirée à vous

Thibault

Hello Eric !

Je trie ton tableau avant, pour simplifier, à voir si c'est rédhibitoire. L'utilisation d'un dico comme Theze permet de s'en passer.

Seul le résultat compte que ce soit avec un tri, avec un dico ou avec toutes autres méthodes

Bonjour,

à tester,

Sub test()
'activer la référence "Microsoft Scripting Runtime"
Dim Dico As New Scripting.Dictionary

For i = 2 To 13 'plage à déterminer
    Cle = Right(Cells(i, 1), Len(Cells(i, 1)) - 2)
    t = Left(Cells(i, 1), 1)

    If Not Dico.Exists(Cle) Then
        Dico.Add Cle, t
    Else
        n = Application.Match(Cle, Dico.Keys, 0) - 1
         x = Dico.Items(n) & t
        Dico.Remove Cle
        Dico.Add Cle, x
    End If
Next

Cells(2, 13).Resize(Dico.Count, 1) = Application.Transpose(Dico.Keys)
Cells(2, 14).Resize(Dico.Count, 1) = Application.Transpose(Dico.Items)

Set Dico = Nothing
End Sub

Seul le résultat compte

Bah oui. Mais si c'est plus court et moins invasif c'est quand même mieux.

Tu y as pensé, Sabv y a pensé, moi non, Je suis déçu

Bonsoir à tous,

Une autre version :

Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets(1).Range("a1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To 1)
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 2)) Then
            n = n + 1
            dico(a(i, 2)) = n
        End If
        b(dico(a(i, 2)), 1) = IIf(b(dico(a(i, 2)), 1) = "", _
                                  a(i, 2) & a(i, 1), b(dico(a(i, 2)), 1) & a(i, 1))
    Next
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("restitution").Delete
    Sheets.Add(after:=Sheets(1)).Name = "restitution"
    On Error GoTo 0
    With Sheets("restitution").Range("a1")
        With .Resize(n, 1)
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .VerticalAlignment = xlCenter
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Re tfery,

Plutôt celle-ci :

Option Explicit
Sub test()
Dim a, b(), e, i As Long, n As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    For i = 60 To 105 Step 5
        n = n + 1
        dico(CStr(i)) = n
    Next
    ReDim b(1 To dico.Count, 1 To 1)
    For Each e In dico.keys
        b(dico(e), 1) = e
    Next
    a = Sheets(1).Range("a1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        b(dico(a(i, 2)), 1) = b(dico(a(i, 2)), 1) & a(i, 1)
    Next
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("restitution").Delete
    Sheets.Add(after:=Sheets(1)).Name = "restitution"
    On Error GoTo 0
    With Sheets("restitution").Range("a1")
        With .Resize(UBound(b, 1), 1)
            .NumberFormat = "@"
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 11
            .BorderAround Weight:=xlThin
            .VerticalAlignment = xlCenter
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Bonsoir,

Voici une manière de procéder SANS VBA.

Il y a un "Mode d'emploi" et un Comment cela marche" dans l'onglet Mode d'emploi du classeur.

Merci de confirmer que cela correspond à tes attentes.

N'hésites pas à poser les questions nécessaires.

A+

Chris

Bonjour à tous,

Thibault, voici un autre exemple avec le tri numérique, comme l'exemple montré avec résultat souhaité,

modifier Cells(2 + i, 6) = par Cells(2 + i, 4) = pour mettre les résultats en colonne D

Sub test()
'activer la référence "Microsoft Scripting Runtime"
Dim dico As New Scripting.Dictionary, i As Long
Dim Cle, t, x

For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row 'plage à déterminer, ici dernière de la colonne B
   Cle = Cells(i, 2) * 1
    t = Cells(i, 1).Value

    If Not dico.Exists(Cle) Then
        dico.Add Cle, t
    Else
        x = dico.Items(Application.Match(Cle, dico.Keys, 0) - 1) & t
        dico.Remove Cle
        dico.Add Cle, x
    End If
Next

For i = 0 To dico.Count - 1
 x = Application.Small(dico.Keys, i + 1)
 Cells(2 + i, 6) = x & Application.Index(dico.Items, Application.Match(x, dico.Keys, 0))
Next

Set dico = Nothing
End Sub

salut à tous,

j'ai ajouté un tri de la plage de données au cas ou celle-ci n'a pas été fait préalablement,

Range("A:B").Sort key1:=Range("A1"), Header:=xlYes, order1:=xlAscending

Merci pour toutes ces versions c'est super gentil

Bon vendredi

Thibault

Merci pour toutes ces versions c'est super gentil

Merci pour ce retour, au plaisir!

si le problème cas no. 1 est résolu, s.v.p. pour clôturer le fil, cliquer sur le bouton V vert du post à coté du bouton EDITER, merci!

pour votre cas no. 2 je n'ai rien compris, alors je vous suggère de créer un nouveau fil.