Rangement de colonne en ligne continue selon critere

Le 30/10/2014 à 15:20

Bonjour,

Je viens vers la communauté pour résoudre un problème pour un grand novice comme moi. J'ai parcouru plusieurs forums mais je n'arrive pas à coder ce truc.

Je dois ranger un tableau selon le critère contenu dans la première colonne de chaque ligne. Tant que le critère est rempli en lisant la colonne 1 je dois recopier le contenu des 3 cellules suivantes sur la même ligne d'un autre tableau en continuité. Lorsque le critère n'est plus rempli on passe au critère suivant et on recopie sur la ligne suivante ... etc ...

Comme il est plus simple de comprendre avec un modèle voir la pj. (feuille source et feuille rangee à obtenir)

J'ai 3000 lignes à traiter ....

Une solution j'en suis sur ?

Merci de votre aide.

29classeur1.xlsx (9.51 Ko)
Le 30/10/2014 à 16:27

Bonjour,

une proposition

Sub test()
    Set wsi = Sheets("feuillesource") 'wsi=feuille source
    Set wso = Sheets("feuillerangee") 'wso=feuille cible
    dli = wsi.Cells(Rows.Count, 1).End(xlUp).Row 'nbr lignes sur wsi
    wso.Cells.ClearContents ' on efface le contenu de wso
    wsi.Rows(1).Copy wso.Range("A1") ' copie de la ligne titre de wsi vers wso
    dlo = 1 'pointeur de ligne dans wso
    dco = 1 'pointeur de colonne dans wso
    maxdco = dco ' indicateur de la colonne max atteinte,utilise pour prolonger les entêtes de colonnes
    For i = 2 To dli 'on parcourt les lignes de wsi
        If i > 2 And wsi.Cells(i - 1, 1) = wsi.Cells(i, 1) Then
         'si pas la premire ligne et si la valeur de la ligne en cours est la même que celle de la ligne précedente
         ' la première colonne à copier est la colonne B
            fc = "B"
        Else
        ' sinon 'nouvelle ligne
        ' la première colonne à copier est la colonne a
            fc = "A"
            dco = 1 ' on remet le pointeur de colonne à 1
            dlo = dlo + 1 'on incrémente le pointeur de ligne
        End If
        If dco > maxdco Then wsi.Range("B1:E1").Copy wso.Cells(1, dco): maxdco = dco ' on prolonge le titre
        wsi.Range(fc & i & ":E" & i).Copy wso.Cells(dlo, dco) 'on copie les données de wsi vers wso
        If dco = 1 Then dco = 2 'on adapte le pointeur de colonnes
        dco = dco + 4 'on adapte le pointeur de colonnes
    Next i
End Sub

edit : ajout de commentaires dans le code

Le 30/10/2014 à 16:34

Ouah impressionnant de rapidité.

Ca à l'air de fonctionner et je vais analyser ce code pour bien comprendre la manip.

J'avais commencer un truc mais rien à voir.

Je reviendrai fermer le sujet si test concluant.

Merci.

Le 30/10/2014 à 16:36

Bonjour Rcbuzz, h2so4, bonjour le forum,

Beaucoup plus long que h2so4 mais je te propose quand même :

Sub Macro1()
Dim OS As Object 'déclare la variable OS (Onglet Source)
Dim OD As Object 'déclare la variable OD (Onglet Destination)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim LI As Integer 'déclare la variable LI (Ligne)
Dim COL As Integer 'déclare la variable COL (COLonne)
Dim OF As Byte 'déclare la variable OF (OFfset)

Set OS = Sheets("FeuilleSource") 'définit l'onglet source OS (à adapter)
Set OD = Sheets("FeuilleRangee") 'définit l'onglet destination OD (à adapter)
DL = OS.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet OS
Set PL = OS.Range("A2:A" & DL) 'définit la plage PL
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle sur toutes les cellules CEL de la plage PL
    D(CEL.Value) = "" 'alimente le dictionnaire D
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récuperedans le tableau temporaire TMP les éléments du dictionnaire D sans doublon
For I = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau TMP
    OS.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre en A1 la colonne 1 (=A) de l'onglet OS
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'définit la plage PLV (cellules visibles (non filtrées) de la palge PL)
    LI = OD.Cells(Application.Rows.Count, 1).End(xlUp).Row + 1 'définit la ligne LI de l'onglet OD
    For Each CEL In PLV 'boucle 2 : sur toutes les cellules de la plage PLV
        OD.Cells(LI, 1).Value = TMP(I) 'place l'élément TMP(I) dans la la colonne 1 de la ligne LI de l'onglet OD
        For OF = 1 To 4 'boucle 3 : sur les 4 noms
            COL = OD.Cells(LI, Application.Columns.Count).End(xlToLeft).Column + 1 'définit la colonne COL
            OD.Cells(LI, COL).Value = CEL.Offset(0, OF).Value 'place la valeur du nom 1 dans la cellule colonne COL, ligne LI de l'onglet OD
        Next OF 'prochain nom de la boucle 3
    Next CEL ''prochain élément de la boucle 2
    OS.Range("A1").AutoFilter 'supprime le fitre automatique
Next I 'prochain élément de la boucle 1
End Sub
Le 30/10/2014 à 18:00

Merci à vous 2. Ai testé et tout fonctionne comme mon souhait.

Cdt,

Rechercher des sujets similaires à "rangement colonne ligne continue critere"