Fusion de lignes

SOLUTION :

dubois a écrit :

Bonjour Vincent et à tous,

cette macro te copie la feuille et fusionne les données. (l'original reste intact).

''Macros par Claude Dubois pour "vincentjuan" Excel-Pratique le 11 août 2008

Sub Fusion()
   Sheets("Droits utilisateurs").Copy After:=Sheets(1) 'copie la feuille
    [a2].Activate
    [A65536].End(xlUp)(2) = "Stop"

    Do While ActiveCell <> ""
saute:
        ActiveCell.Name = "top"
        ActiveCell.Offset(0, 17) = "fin"
                    If ActiveCell = "Stop" Then Exit Sub
                    If ActiveCell.Offset(1, 0) <> [Top] Then
                        ActiveCell.Offset(1, 0).Select
                        GoTo saute
                    End If
                Do While ActiveCell.Offset(1, 0) = [Top]
                    ActiveCell.Offset(1, 0).Select
                Loop
                ActiveCell.Name = "top2"
                bip = 1
            Do While ActiveCell <> "fin"
                 [Top:top2].Offset(0, bip).Select
                 Selection.Sort Key1:=[Top].Offset(0, bip), Order1:=xlAscending, Header:=xlGuess, _
                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
                 bip = bip + 1
                 ActiveCell.Offset(0, 1).Select
            Loop
                Range([Top].Offset(1, 0), [top2]).EntireRow.Delete
                [Top].Offset(1, 0).Select
    Loop
End Sub

à vérifier si la 1ère donnée est bien en A2

amicalement

Claude.

SOLUTION 2 :

Nad-Dan a écrit :

Bonjour,

Comme j'y ait travaillé, voici la macro donnée par Nad réadaptée et plus rapide :

Option Explicit
Sub Regrouper()
'Macro adaptée par Dan pour vincentjuan - XL pratique 11/08/08
Dim Nom As Range
Dim i As Integer
Dim j As Byte
Dim Val As Range
Application.ScreenUpdating = False
With ActiveSheet
    .UsedRange.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Each Nom In .Range("A2:A" & Range("A65536").End(xlUp).Row)
For i = 1 To .Range("A65536").End(xlUp).Row - 1
Set Val = Nom.Offset(i, 0)
If Val <> "" And Val = Nom Then
j = 1
Do While j <> 17 'ajouté par vincentjuan : remplacer '17' par le nombre de colonnes à traiter
If Nom.Offset(i, j) <> "" Then
Nom.Offset(i, j).Copy Nom.Offset(i - 1, j)
End If
j = j + 1
Loop
Rows(Val.Row).Delete
i = i - 1 'si deux noms identiques se suivent
End If
Next i
Next Nom
End With
End Sub

A placer dans un module en VBA et lui associer un bouton.

Amicalement

Dan

PROBLEME INITIAL :

Bonjour à toutes tous,

Je suis nouveau sur le forum et je découvre cet intéressant logiciel qu'est Excel dans sa version 2003 durant un contrat saisonnier dans une institution ministérielle.

J'ai supposé en tapant "Forum Excel" dans Google, tomber sur le bon forum où les vrais "pros" 8) pourraient m'aider.

Mon problème est le suivant :

J'ai un tableau qui s'étend sur un bon millier de lignes et quelques colones. La première colone contient une liste de noms, les autres affichent les divers droits d'accès a des sous-sites collaboratif pour chaque utilisateur.

Je voudrais fusionner verticalement les lignes contenant les noms et les valeurs.

En effet vous le voyez au lieu de rassembler les droits de chaque personne sur une seule et même ligne, ils sont dispatchés sur plusieurs lignes. Une seule et même personne occupe plusieurs lignes donc.

Il me faudrait pouvoir en un clic rassembler dans l'ensemble du tableau, en une ligne par personne, toutes les valeurs des droits.

Si vous aviez une macro toute faite à utiliser sur tout le tableau ou un groupe de lignes au même nom, ou une explication, je suis preneur!

Je vous remercier d'avance!

Bien cordialement,

Vincent JUAN

Bonjour,

Regarde ce fichier - Macro de CbernardT

Amicalement

Nad

Bonsoir,

Je vais tester demain au bureau sur mon XLS dans Excel 2003, mais j'ai d'ores et déjà testé avec l'exemple integré à ce fichier de macro et cela fonctionne sous la dernière version de NeoOffice Mac. Il n'y pas de raisons que ça ne fonctionne pas au bureau je pense...

Je teste ça et si c'est bon je viens retitrer le topic en résolu.

Merci beaucoup! Bonne nuit!

Cordialement,

Vincent JUAN

Alors, je viens d'essayer, quand j'applique la macro directement dans mon document excel ça semble le planter, je voudrais bien vous passer mon XLS pour faire des essais malheureusement c'est une liste de noms sensibles et mon chef refuse.

J'ai tenté de supprimer le contenu du XLS d'exemple et de le remplaçer par le contenu de mon XLS, ou du moins les 20 premières lignes.

Lorsque je clique sur le bouton orange de triage cela fonctionne mais seulement sur une partie des noms, et seulement sur une partie des colones.

En effet le tableau d'exemple compte infiniment moins de lignes, et moins de colones que le mien.

Je suppose que la macro a été configurée dans ce sens... Je vais peut être devoir la modifier pour l'adapter à mon tableau.

Est-il possible de l'adapter pour un document contenant un nombre illimité de lignes et de colones?

Par exemple le miens fait a peu près 1150 lignes et occupe les colones A à Q.

Je ne comprend rien au Visual Basic alors je sollicite à nouveau votre aide.

Merci par avance!

Cordialement,

Vincent JUAN

P.S: Le code original de la Macro si ça peut vous éclairer.

Option Explicit
Option Base 1
Sub Trier()
' Macro enregistrée le 28/05/2006 par CBernardT
Dim Lig As Long, i As Long, j As Long, k As Byte, n As Integer, X As Byte

Application.ScreenUpdating = False
Lig = Range("A65536").End(xlUp).Row
'Report des dates des lignes des mêmes projets
For i = 4 To Lig
   ' Nombre d'occurence du projet
   For n = 4 To Lig
   If Cells(n, 1) = Cells(i, 1) Then
   X = X + 1
   End If
   Next n
If X > 1 Then ' S'il y en a plus d'une
' Recherche des occurences du projet
   For j = i + 1 To Lig
      If Cells(j, 1) = Cells(i, 1) Then
         ' Report de la date
         For k = 4 To 8
         If Cells(j, k) <> "" Then
         Cells(i, k) = Cells(j, k)
         Cells(i, k).Interior.ColorIndex = Cells(j, k).Interior.ColorIndex 'Coloration
         Range(Cells(j + 1, 1), Cells(Lig + 1, 8)).Copy Cells(j, 1) ' Remontée du tableau
         End If
         Next k
      End If
   Next j
End If
X = 0
Next i
Application.ScreenUpdating = True
End Sub

Bonjour,

Dans la partie :

For k = 4 To 8

If Cells(j, k) <> "" Then

Cells(i, k) = Cells(j, k)

Cells(i, k).Interior.ColorIndex = Cells(j, k).Interior.ColorIndex 'Coloration

Range(Cells(j + 1, 1), Cells(Lig + 1, 8)).Copy Cells(j, 1) ' Remontée du tableau

End If

Remplace les 8 par 17

Teste et dis nous.

Amicalement

Nad

Bonjour,

J'ai tenté en remplaçant la valeur 8 par 17 (comme 17 colonnes) dans la macro, rien n'y fait.

Sinon j'avais trouvé cette macro qui avait partiellement fonctionné (restaient des doublons encore, seules 4 colones étaient traitées et surtout elle plantait après avoir traité une centaine de lignes ...), ça fera peut être avancer le schmilblick!

*Lien de fichier supprimé car RESOLU*

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 31/07/2008 by LSD
'
For j = 2 To ActiveSheet.UsedRange.Rows.Count
    For i = j + 1 To ActiveSheet.UsedRange.Rows.Count
    If Cells(i, 1).Value = Cells(j, 1).Value And Cells(i, 2).Value = Cells(j, 2).Value And Cells(i, 3).Value = Cells(j, 3).Value Then
        Cells(j, 4) = Cells(j, 4) + Cells(i, 4)
        Rows(i & ":" & i).Select
        Selection.Delete
        i = i - 1
     End If

    Next i
Next j
'
End Sub

(Macro de LSD)

Je désespère un peu je me demande si les machines que j'utilise sont trop molles, si j'en demande trop à excel (appliquer la macro sur trop de lignes d'un coups), ou si je vous explique mal ce que je veux obtenir comme résultat dans ce post. En tout cas rien ne marche, ni sous 2003 ni sous la dernière version de NeoOffice Calc ...

Je vous met le fichier excel, mais chut hein parce que si mon boss s'en apercevait je me ferais gronder y'a des noms dedans. En même temps, rien de top secret, une liste de profs...

*Lien de fichier supprimé car RESOLU*

Je récapitule : en gros, il faudrait une macro qui fusionne toutes les lignes dont la première cellule contient le même nom. En effet j'ai des redondances des mêmes noms sur toute les lignes du tableau, mais avec à chaque fois des valeurs différentes dans des colones différentes. Et je voudrais me retrouver avec un tableau ou chaque nom n'apparait qu'une seule fois sur une seule ligne, avec toutes ses valeurs dans chaque colonne de sa ligne.

Très bonne journée à toutes et tous,

Cordialement,

Vincent JUAN

Bonjour Vincent et à tous,

cette macro te copie la feuille et fusionne les données. (l'original reste intact).

''Macros par Claude Dubois pour "vincentjuan" Excel-Pratique le 11 août 2008

Sub Fusion()
   Sheets("Droits utilisateurs").Copy After:=Sheets(1) 'copie la feuille
    [a2].Activate
    [A65536].End(xlUp)(2) = "Stop"

    Do While ActiveCell <> ""
saute:
        ActiveCell.Name = "top"
        ActiveCell.Offset(0, 17) = "fin"
                    If ActiveCell = "Stop" Then Exit Sub
                    If ActiveCell.Offset(1, 0) <> [Top] Then
                        ActiveCell.Offset(1, 0).Select
                        GoTo saute
                    End If
                Do While ActiveCell.Offset(1, 0) = [Top]
                    ActiveCell.Offset(1, 0).Select
                Loop
                ActiveCell.Name = "top2"
                bip = 1
            Do While ActiveCell <> "fin"
                 [Top:top2].Offset(0, bip).Select
                 Selection.Sort Key1:=[Top].Offset(0, bip), Order1:=xlAscending, Header:=xlGuess, _
                 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
                 bip = bip + 1
                 ActiveCell.Offset(0, 1).Select
            Loop
                Range([Top].Offset(1, 0), [top2]).EntireRow.Delete
                [Top].Offset(1, 0).Select
    Loop
End Sub

à vérifier si la 1ère donnée est bien en A2

amicalement

Claude.

Bonjour Claude !

Là tu as fait très, très fort ! Tout fonctionne à merveille ...

Un grand merci personnel et de la part de tous ceux à qui ça pourra servir dans mon service, et sur le forum, par avance.

Une macro à garder sous le coude, très certainement.

Je te souhaite une excellente journée.

Merci à tous.

Cordialement,

Vincent JUAN

re,

Content que çà marche, mais petite question :

qu'est-ce que c'est comme fichier, il fait 1000 ko et on l'ouvre sans déziper ??

Claude.

C'est un XLS qui contient deux feuilles de calcul avec mise en forme colorée, et en tout plus de 1000 lignes étalées sur 17 colonnes.

D'où le poid sur-abusé. Mais je n'ai que deux jours d'ancienneté sur ce logiciel donc ...

Bonjour,

Comme j'y ait travaillé, voici la macro donnée par Nad réadaptée et plus rapide :

Option Explicit
Sub Regrouper()
'Macro adaptée par Dan pour vincentjuan - XL pratique 11/08/08
Dim Nom As Range
Dim i As Integer
Dim j As Byte
Dim Val As Range
Application.ScreenUpdating = False
With ActiveSheet
    .UsedRange.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Each Nom In .Range("A2:A" & Range("A65536").End(xlUp).Row)
For i = 1 To .Range("A65536").End(xlUp).Row - 1
Set Val = Nom.Offset(i, 0)
If Val <> "" And Val = Nom Then
j = 1
Do While j <> 17
If Nom.Offset(i, j) <> "" Then
Nom.Offset(i, j).Copy Nom.Offset(i - 1, j)
End If
j = j + 1
Loop
Rows(Val.Row).Delete
i = i - 1 'si deux noms identiques se suivent
End If
Next i
Next Nom
End With
End Sub

A placer dans un module en VBA et lui associer un bouton.

Amicalement

Dan

Et hop! Une deuxième solution qui fonctionne tout aussi intéressante et efficace que celle de Claude, quoi qu'un peu différente.

Un grand merci Dan !

Il est tip-top ce forum !

Cordialement,

Vincent JUAN

Bonjour

Intrigué, j'ai réalisé la macro en XL4.

Apparemment, elle fonctionne correctement.

A titre de curiosité, pour Claude, le fichier tombe à moins de 150 Ko, dès qu'on supprime la floppée d'images invisibles qui l'encombrent.

https://www.excel-pratique.com/~files/doc/Droits.zip

Cordialement

bonjour Amadéus, Dan et les autres,

Qu'est-ce qui t'intriguait ?

• J'ai jeté un oeil sur ta macro1, tu n'a pas pu t'empêcher de mettre des formules matricielles !!!
• hélas, je n'ai pas osé la lancer car j'ai eu trop de mal à me débarrasser d'une macro parasite "excel4". (voir mon 1er message sur ce forum).

Moi, ce qui m'étonnait, c'est qu'on puisse ouvrir le fichier de notre ami Vincent sans le décompresser. !

Enfin, maintenant il a le choix et je pense qu'il nous fera une bonne Pub !

Amicalement

Claude.

Bonjour claude

Ce qui m'intriguait?

Simplement que je me demandais comment arriver au résultat car, à priori, je ne savais pas faire.

Les matricielles sont utilisées dans la macro, mais aussitôt supprimées et remplacées par leur résultat, le fichier n'en comporte donc aucune, les formules étant immédiatement remplacées par leur valeur.

Quant au risque, la macro XL4 offre comme avantage d'être lisible en français et donc, de dévoiler ouvertement toutes les instructions lorsque la Macro est accessible, ce qui est le cas.

Je te remercie de laisser penser qu'une Macro transmise par un Modérateur pourrait être "Malveillante". Pas trés sympa...

Cordialement

Re,

Claude, je pense que si tu as hérité d'une macro parasite c'est dû au fait que tu as ouvert un fichier réalisé par un "apprenti sorcier" comme beaucoup qui s'initient à faire des macros sans trop connaitre quelles sont les retombées pour les utilisateurs.

Je ne pense pas qu'Amadeus soit ce genre de personne car j'ai pu constater que ses macros XL4 prévoient de remettre tout en ordre à la fermeture du fichier.

Petit coucou aux concepteurs d'excel pour MAC, car lorsque l'on refuse d'ouvrir un fichier avec du VBA et que ce même fichier a été réalisé sous une ancienne version avec macro XL4, on reçoit un deuxième message qui permet d'accepter ou non.

Amicalement

Dan

Bonsoir,

je me suis également fait plaisir, avec ce code :

Sub Fusion()
Application.ScreenUpdating = False
Dim cel As Range
Range("A1:Q" & [A65000].End(xlUp).Row).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess
Set mondico = CreateObject("Scripting.Dictionary")
For Each cel In Range("A2:A" & [A65000].End(xlUp).Row)
     If Not mondico.Exists(cel.Value) Then mondico.Add cel.Value, cel.Address
Next cel
b = mondico.items
For i = UBound(b) To LBound(b) Step -1
    X = Application.CountIf(Range("A:A"), Range(b(i)).Value)
    If X > 1 Then
        Range(b(i)).Resize(X, 1).Name = "Noms"
        For Each cel In [Noms]
            dd = cel.End(xlToRight).Column
            Range(b(i)).Offset(0, dd - 1).Value = Cells(cel.Row, dd).Value
        Next cel
        Range(b(i)).Offset(1, 0).Resize(X - 1, 1).EntireRow.Delete
       End If
Next i
End Sub

Amadéus,

non, loin de moi cette pensée !!

mes propres macros, même insignifiantes, me déclenchaient ce "parasite"

Cela devait venir d'une xla planquée et que je n'ai jamais trouvé !

c'est pourquoi, je ne veux pas prendre le risque de relancer une macro excel4.

D'ailleurs, j'ai réécrit toutes les miennes et changer de répertoire racine.

D'accord avec toi, la lecture est plus facile, mais on s'y fait assez vite.

Si tu regarde la macro à Dan, qui lui, est un expert en VBA, j'ai du mal à la lire.

pour en revenir au fichier de Vincent, comment as-tu fait pour voir des images invisibles ??

amicalement

Claude.

Bonjour

pour en revenir au fichier de Vincent, comment as-tu fait pour voir des images invisibles ??

Bien sur, voir l'invisible est inapproprié. C'est une manière de dire, et tu pourras le constater, qu'un très grand nombre de cadres images sont dans le fichier, mais comme le fichier contenant les images n'est pas joint, il reste le cadre vide avec "Image numéro"

Pour te rendre compte, tu reviens sur le fichier initial et tu fais un "Edition" "Atteindre", tu cliques sur "Cellules" et tu coches "Objet"

Cordialement

re,

oui, effectivement !

et comment supprimer toutes ces images ?

à part copier la base et collage spécial Valeur sur une autre feuille, je ne vois pas.

Claude.