Transposer automatiquement selon une règle

[califmeg27]

Bonjour,
Je suis débutante en VBA et cela fait plus d'une semaine que je bute sur un problème malgré mais nombreuses recherches...
En fait, je dispose d'une liste de 10000 références que je souhaite transposer en fonction de leur préfixe. Je souhaite que toutes les références ayant le même préfixe (composé de 6 chiffres) soit transposer sur la même ligne.
Le fichier vous permettra de me comprendre car je suis pas sur d'être bien claire....
Merci d'avance à ceux qui m'aideront!!!
Mymy

 

[MJ13]

Re : Transposer automatiquement selon une règle

Bonjour MyMy

En attendant les pures VBAistes, un petit test avec un TCD et une macro.

 

[tototiti2008]

Re : Transposer automatiquement selon une règle

Bonjour Mymy, Bonjour Michel

Bienvenue sur XLD

Une version VBA pour compléter la proposition de Michel

Edit : Bonjour Robert 😉 , jolie couleur trés seyante 😀
Si tu veux de l'appui, je peux essayer de me mettre à ta charte 😉

 

[Robert]

Re : Transposer automatiquement selon une règle

Bonjour Califmeg et bienvenu, bonjour le forum,

En pièce jointe ton fichier modifié avec la macro ci-dessous :

Sub Macro1()
Dim dest As Range 'déclare la variable dest (DESTination)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim pr As String 'déclare la variale pr (PRemier)
Dim au As String 'déclare la variale au (AUtre)
Dim li As Long 'déclare la variable li
 
debut: 'étiquette
pr = Left(Range("A2"), 6) 'définit la variable pr (les 6 premiers caractères de A2)
Set pl = Range("A3:A" & Range("A65536").End(xlUp).Row) 'définit la plage pl (de A3 à A & dernière ligne éditée)
For Each cel In pl 'boucle sur toutes les cellules cel de la plage PL
    au = Left(cel.Value, 6) 'définit la variable au (les 6 premiers caractères de la cellule cel)
    If au <> pr Then 'condition : si les deux variables sont différentes
        li = cel.Row - 1 'définit la ligne li
        If li = 0 Then Exit Sub 'si li=0 sort de la procédure (tout a été transposé)
        Exit For 'sort de la boucle
    End If 'fin de la condition
Next cel 'prochaine cellule de la boucle
Set dest = Range("C65536").End(xlUp).Offset(1, 0) 'définit la cellule de destination dest
Range(Cells(2, 1), Cells(li, 1)).Copy 'copie la plage dont les 6 premiers caractères sont identiques
dest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True 'transpose dans dest
Range(Cells(2, 1), Cells(li, 1)).Delete Shift:=xlShiftUp 'supprime la plage en décalant vers le haut
GoTo debut 'recommence l'opération via l'étiquette "début"
End Sub

[Édition]
Bonjour MJ13, Tototiti on s'est croisé.

 

[James007]

Re : Transposer automatiquement selon une règle

Bonjour Myriam, Salut Michel, Robert, et Tototiti2008 🙂

A mon humble avis, pour 10'000 références ou plus, le Superbe code de Tototiti2008 😎 s'impose ...

Et, comme a priori, tu as besoin de ne pas prendre en compte les images jpeg qui contiennent dans leurs intitulés : ON et OFF, il n'y a juste qu'une toute petite modif à faire ...

Sub TransposAuto()
Dim i As Long, Dico, Deb As String, res, v, Ligne As Long, j As Long, DerLigne As Long, Col As Long
    
    DerLigne = Range("A65536").End(xlUp).Row
    Range("D2:G" & DerLigne).ClearContents
    
    Set Dico = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    DerLigne = Range("A65536").End(xlUp).Row
    For i = 2 To DerLigne
        Deb = Left(Cells(i, 1).Value, 6)
        Dico.Add Deb, Deb
    Next i
    
    On Error GoTo 0
    res = Dico.Items
    For i = LBound(res) To UBound(res)
    Col = 4
        Ligne = Range("D65536").End(xlUp).Row + 1
        For j = 2 To DerLigne
      ' Supprimer avec une condition les images ON et OFF
      If InStr(1, Cells(j, 1).Value, "ON") = 0 And InStr(1, Cells(j, 1).Value, "OFF") = 0 Then
                If Cells(j, 1).Value Like res(i) & "*" Then
                    Cells(Ligne, Col).Value = Cells(j, 1).Value
                    Col = Col + 1
                End If
      End If
        Next j
    Next i
End Sub

A +
🙂

 

[califmeg27]

Re : Transposer automatiquement selon une règle

Whaou!!, je suis épatée par votre talent! et quelle réactivité!!!!!
En tout cas, un grand merci à tous, le code de toto avec le bouton en prime fonctionne à merveille et c'est exactement ce dont j'avais besoin!!!

Pendant que j'y suis, maintenant je dois associer ces données (les 2, 3, 4, 5, ou 6 cellules tranposées) à une feuille ou se trouve la référence correspondante.

Je vous joins un nouveau fichier pour vous expliquer...

Sachant qu'un simpe copier coller ne suffit pas puisqu'il y a parfois des références sans images....

Merci pour vos lumières et encore merci pour votre travail, vous m'avez enlevé une sacrée épine là!!!!!!