Regrouper plusieurs colonne en une seule

bonjour,

je me permet de vous solliciter, dans la cadre d'un projet, je dois rassembler 20 projets sur 5 ans (1829 lignes) et trois données sont rapatriées : la date de mise en production, la valeur et le projet (fichier en copie).

pour se faire, j'ai modifier un code vba que j'ai trouvé :

Sub Regroupe()
Dim i%, j%, dl%, y%, n%
dl = 4 '1ère ligne du tableau chiffre
dy = 4 '1ère ligne du tableau pour date
dn = 4 '1ère ligne du tableau pour date
Range("p4:p5000") = "" 'vide ancienne valeur
Range("q4:q5000") = "" 'vide ancienne valeur
Range("r4:r5000") = "" 'vide ancienne valeur
For i = 10 To 14 Step 4 'boucle une colonne sur 4
  For j = 4 To 1829 'boucle ligne'si la cellule n'est pas vide
    If Cells(j, i).Value <> "" Then 'si la cellule n'est pas vide
      Cells(dl, 17).Value = Cells(j, i).Value 'je rempli la colonne Q
      dl = dl + 1 ' je déclare la Dl avec une ligne de plus
      End If
        For y = 1 To 1
            If Cells(j, i).Value <> "" Then 'si la cellule n'est pas vide
        Cells(dy, 16).Value = Cells(j, y).Value 'je rempli la colonne P
        dy = dy + 1 ' je déclare la Dl avec une ligne de plus
        End If
        Next y
            For n = 3 To 3 'boucle une colonne sur 4
            If Cells(j, i).Value <> "" Then 'si la cellule n'est pas vide
            Cells(dn, 18).Value = Cells(n, i).Value 'je rempli la colonne q
            dn = dn + 1 ' je déclare la Dl avec une ligne de plus
            End If
            Next n
  Next j
Next i
End Sub

la procédure est très longue d'exécution, plus de 2-3mn.

j'ai vu sur le forum un code proposé par h2so4 qui permet de copier les colonnes très rapidement mais exclue les doublons (ce qui dans mon cas n'est pas souhaitable).

Private Sub regrouper() 

    With Sheets("Feuil1")
        dl = .Cells(1829, 10).Row '.Cells(Rows.Count, 3).End(xlUp).Row '' permet de prendre toutes les lignes du bas de la feuille vers le haut
        dc = .Cells(4, 14).Column '.Cells(43, Columns.Count).End(xlToLeft).Column '' permet de prendre toutes les cololnnes de la droite de la feuille vers la gauche
        Set dict = CreateObject("scripting.dictionary")
        For i = 4 To dl
            For j = 10 To dc Step 4
                v = .Cells(i, j).Value
                If v <> "" Then dict(v) = 1
            Next j
        Next i
        Cells(4, 19).Resize(dict.Count) = Application.Transpose(dict.keys)
        'Cells(4, 19).Resize(dict.Count) = Application.Transpose(dict.keys)

    End With
End Sub

Edit modo : Merci de mettre les codes entre balises </>

après recherche,

dictionary = supprime les doublons

Auriez vous une idée, pour gagner du temps sur la première ou permettre les doublons sur la seconde ?

d'avance merci de votre aide et de votre expérience

(je suis débutant en vba, mais avec une certaine compréhension des codes (je peux adapter, comprendre le cheminement, mais pour l'instant, je n'en crée pas ou des très simple)

Bonjour,

si ta procédure est correcte d'un point de vue fonctionnel, remplace alors les cells par un array, et colle en fin de macro comme le fait h2so4, cela ira 100 fois plus vite ! C'est là que réside la solution de rapidité.

mais je n'ai pas bien compris pourquoi tu ne faisais pas un TCD !

merci pour la réponse rapide, le but est d'exploiter le tableau de 3 colonnes regroupé en tdc pour effectuer un suive et ça me permet d'éviter d'avoir les projets en colonne pour avoir les résultats mais du coup en ligne.

je vais essayer array ce soir (je vais voir comment ça marche )

trueblood a écrit :

merci pour la réponse rapide, le but est d'exploiter le tableau de 3 colonnes regroupé en tdc

du coup tu m’interpelles ? en jaune le tdc que je veux faire grâce aux colonnes regroupés et l'autre tableau ce que ça me donne si je reste sur le tableau source. si tu vois un moyen de faire avec le tableau source comme le résultat souhaité, ça m’intéresse, car là, je ne vois pas. Je suis partant car ça allège le fichier

Première version sans macro

Seconde version

merci Steelson, je vais essayer les différente manière pour voir ce qui est le plus rapide. les 20 tdc à actualiser, les 20 colonnes et la macro array.

les 20 tdc j'y avais songé et je l'ai déjà fait dans un autre de mes projets mais je trouvais ça assez long.

merci à toi pour les différentes pistes

Dans la seconde version, tu n'as qu'un seul TCD

bonjour Steelson,

effectivement le second tableau est mieux avec des liaisons par formule (je voulais m'éviter cela, mais la solution est bien). je reste curieux néanmoins, quant à la modification du code vba (cells par array). En ayant fait quelques recherches (qui n'ont pas abouti), je ne comprends pas la fonction Array. aurais tu une explication sur la fonction (j'aimerai comprendre) et si je peux aussi abuser un exemple vis à vis de ma procédure vba que j'avais indiqué svp.

d'avance merci de ton aide (déjà apportée)

Dim NomTableau As Variant

NomTableau = Array("a", "b", "c")

a-b-c sont les colonnes ? si je veux définir une zone (colonne A ligne 4 à colonne N ligne 1829), comment je peux faire ?

J'ai bien essayé, mais j'ai fini par voir que tu avais des erreurs #N/A dans tes données ...

Pour emporter le tout dans un tableau, je fais :

Sub test()
Dim tbl
    tbl = Range("A3").CurrentRegion
    MsgBox UBound(tbl) & " lignes"
    MsgBox UBound(tbl, 2) & " colonnes"
    MsgBox tbl(1, 1) & " = premier élément"
    MsgBox IsError(tbl(UBound(tbl), UBound(tbl, 2))) & " : erreur sur dernier élément"
End Sub

tu peux ensuite travailler aussi avec des tableaux q(), p(), r()

et en fin de travail les transposer dans ta feuille

J'ai malheureusement abandonné la transcription de ton code (que je ne comprends pas bien) à cause des #N/A

l'erreur #N/A est liée à la ligne 1830 du tableau dont il ne faut pas tenir compte.

si je comprends bien, le code indiqué me permet de dimensionner mon tableau sur lequel ensuite je vais pouvoir faire des recherches (de colonnes) et faire des copiés collés.

naïvement je me suis dit que je pouvais l'intégrer du coup au code de h2so4... mais non...

Sub test()

Dim tbl

tbl = Range("A3").CurrentRegion

dl = UBound(tbl) - 1 'je ne tiens pas compte de la linge 1830

dc = UBound(tbl, 2)

IsError (tbl(UBound(tbl) - 1, UBound(tbl, 2)))

Set dict = CreateObject(tbl(UBound(tbl) - 1, UBound(tbl, 2)))

For i = 4 To dl

For j = 10 To dc Step 4

v = .Cells(i, j).Value

If v <> "" Then dict(v) = 1

Next j

Next i

Cells(4, 19).Resize(dict.Count) = Application.Transpose(dict.keys)

End Sub

mais non, ils bloquent sur Cells et surement sur d'autres choses. Le monde idéaliste du débutant qui a bcp d'idée mais peu de connaissances

Un esquisse (supprime la dernière ligne de ta feuille qui contient des #N/A)

J'ai en fait repris ton code ou presque ...

Sub testarray()
Dim tbl, p, q, r
    tbl = Range("A3").CurrentRegion
    ReDim p(1 To UBound(tbl))
    ReDim q(1 To UBound(tbl))
    ReDim r(1 To UBound(tbl))
    dl = 1
    dy = 1
    dn = 1
    Range("P4:R" & Range("A" & Rows.Count).End(xlUp).Row).Clear
    For i = 10 To 14 Step 4
        For j = 2 To UBound(tbl)
            If tbl(j, i) <> "" Then     'si la cellule n'est pas vide
                q(dl) = tbl(j, i)       'je rempli la colonne Q
                dl = dl + 1             ' je déclare la Dl avec une ligne de plus
            End If
        For y = 1 To 1
            If tbl(j, i) <> "" Then     'si la cellule n'est pas vide
                p(dy) = tbl(j, y)       'je rempli la colonne P
                dy = dy + 1             ' je déclare la Dl avec une ligne de plus
            End If
        Next y
        For n = 3 To 3                  'boucle une colonne sur 4
            If tbl(j, i) <> "" Then     'si la cellule n'est pas vide
                r(dn) = tbl(n, i)       'je rempli la colonne q ????
                dn = dn + 1             ' je déclare la Dl avec une ligne de plus
            End If
        Next n
        Next
    Next
    Range("P4").Resize(UBound(p)) = Application.Transpose(p)
    Range("Q4").Resize(UBound(q)) = Application.Transpose(q)
    Range("R4").Resize(UBound(r)) = Application.Transpose(r)
End Sub

mais comme je n'ai pas compris ta macro, il faut travailler un poil sur cette base !

Au moins tu peux voir fonctionner des arrays et tu auras une idée du temps d'exécution !

merci Steelson, oui effectivement niveau durée d'exécution, ça n'a rien à voir. je vais voir comment fonctionne la macro.

Ce que tu entends par Arrays (ça n'aide pas de ne pas maîtriser l'anglais), c'est la puissance et l'utilisation des tableaux

je pense que c'est la dernière boucle que tu ne comprends pas, l'idée, c'est que pour les données qu'il cherche il indique l'intitulé de la colonne.

exemple :

date valeur projet

01/01/2019 0

01/04/2019 54,54327273

01/08/2019 5399,784

02/01/2019 6599,736

Exemple :

date valeur projet

01/01/2019 0 projet1

01/04/2019 54,54327273 projet1

01/08/2019 5399,784 projet1

02/01/2019 6599,736 projet1

01/01/2019 0 projet2

01/04/2019 65,45192727 projet2

01/08/2019 196,3557818 projet2

avec Arrays et ma compréhension de fonction lol, je me sens un peu bizuté

le code final qui rapatrie tout est :

Sub testarray()

Dim tbl, p, q, r

tbl = Range("A3").CurrentRegion

ReDim p(1 To UBound(tbl))

ReDim q(1 To UBound(tbl))

ReDim r(1 To UBound(tbl))

dl = 1

dy = 1

dn = 1

Range("P4:R" & Range("A" & Rows.Count).End(xlUp).Row).Clear

For i = 10 To 14 Step 4

For j = 2 To UBound(tbl)

If tbl(j, i) <> "" Then 'si la cellule n'est pas vide

q(dl) = tbl(j, i) 'je rempli la colonne Q

dl = dl + 1 ' je déclare la Dl avec une ligne de plus

End If

For y = 1 To 1

If tbl(j, i) <> "" Then 'si la cellule n'est pas vide

p(dy) = tbl(j, y) 'je rempli la colonne P

dy = dy + 1 ' je déclare la Dl avec une ligne de plus

End If

Next y

For n = 1 To 1 'boucle une colonne sur 4

If tbl(j, i) <> "" Then 'si la cellule n'est pas vide

r(dn) = tbl(n, i) 'je rempli la colonne q ????

dn = dn + 1 ' je déclare la Dl avec une ligne de plus

End If

Next n

Next

Next

Range("P4").Resize(UBound(p)) = Application.Transpose(p)

Range("Q4").Resize(UBound(q)) = Application.Transpose(q)

Range("R4").Resize(UBound(r)) = Application.Transpose(r)

End Sub

encore un grand merci Steelson de ta très grande aide

trueblood a écrit :

merci Steelson, oui effectivement niveau durée d'exécution, ça n'a rien à voir. je vais voir comment fonctionne la macro.

Ce que tu entends par Arrays (ça n'aide pas de ne pas maîtriser l'anglais), c'est la puissance et l'utilisation des tableaux

Personnellement quand je peux éviter VBA je le fais, c'est pourquoi je préfère cette version de TCD https://forum.excel-pratique.com/viewtopic.php?p=874651#p874651