passage a une autre ligne

[softimen]

Bonjour tout le monde,

Je suis débutante en vba , et j'ai besoin de votre aide s'il vous plait .

J'ai cette macro qui permet de grouper les différents données pour deux mémés cellules qui se répètent sur plusieurs lignes.

Mon problème c'est que il regroupe les données seulement pour 2 lignes mais pas plus , je voudrai qui'il regroupe les données sur une mémé ligne qui ont les mémés cellule B et C qui se répètent sur plusieurs lignes .

J'arrive pas a trouver le pb dans mon code qui execute seulement pour 2 lignes .

Merci d'avance.





'code VBA


Function inserer(FL2 As Worksheet, lig As Integer, col As Integer)



If (FL2.Cells(lig, 20) <> "") Then
FL2.Cells(col, 19) = FL2.Cells(lig, 19)
FL2.Cells(col, 20) = FL2.Cells(lig, 20)
FL2.Cells(col, 21) = FL2.Cells(lig, 21)
FL2.Cells(col, 22) = FL2.Cells(lig, 22)



ElseIf (FL2.Cells(lig, 26) <> "") Then
FL2.Cells(col, 25) = FL2.Cells(lig, 25)
FL2.Cells(col, 26) = FL2.Cells(lig, 26)
FL2.Cells(col, 27) = FL2.Cells(lig, 27)



ElseIf (FL2.Cells(lig, 31) <> "") Then

FL2.Cells(col, 30) = FL2.Cells(lig, 30)
FL2.Cells(col, 31) = FL2.Cells(lig, 31)
FL2.Cells(col, 32) = FL2.Cells(lig, 32)


ElseIf (FL2.Cells(lig, 37) <> "") Then

FL2.Cells(col, 36) = FL2.Cells(lig, 36)
FL2.Cells(col, 37) = FL2.Cells(lig, 37)
FL2.Cells(col, 38) = FL2.Cells(lig, 38)

ElseIf (FL2.Cells(lig, 42) <> "") Then

FL2.Cells(col, 41) = FL2.Cells(lig, 41)
FL2.Cells(col, 42) = FL2.Cells(lig, 42)
FL2.Cells(col, 43) = FL2.Cells(lig, 43)


End If

End Function

Sub grouper()
Dim FL2 As Worksheet, i As Integer, j As Integer, h As String, lig As Integer, col As Integer
Set FL2 = Worksheets(4)

For i = 10 To 50
For j = 9 To i - 1
If ((FL2.Cells(i, 2) Like FL2.Cells(j, 2)) And (FL2.Cells(i, 3) Like FL2.Cells(j, 3)) And (FL2.Cells(i, 4) Like FL2.Cells(j, 4)) And (FL2.Cells(i, 5) Like FL2.Cells(j, 5))) Then
col = j
lig = i
h = inserer(FL2, lig, col)
Rows(i).Delete
End If
Next j
Next i
End Sub

 

[vgendron]

Bonjour
avec un fichier en exemple, ce serait plus pratique et plus efficace

 

[softimen]

Bonjour,
Merci pour votre retour rapide
Ci-joint mon fichier
Merci

 

[vgendron]

euh.. il en manque un peu..
1) il faudrait prévenir lorsque ton code (à l'ouverture) modifie les menus contextuel de Excel! parce que c'est chiant après pour enlever le nouveau menu.. du coup. je me retrouve avec quelque chose que je ne souhaite pas.... je te dis pas merci sur ce coup la..

2) ce fameux menu contextuel fait appel à une macro qui n'est meme pas présente dans ton code
3 la macro "grouper" que tu as posté non plus...
4) la fonction que tu souhaites modifier.. elle est appelée par qui ou ca quand??

 

[softimen]

Bonjour,

merci pour votre retour .
Cependant la macro fonctionne très bien comme je vous ai déja dit mais il fusionne seulement 3 lignes

 

[vgendron]

Désolé.. mais tu n'as pas compris mes questions..
le fichier posté ne contient rien de ce que tu décris

et si. parce que je cherche un peu, je lance la macro "Grouper" que j'ai recopiée dans un module..
ca bug ici:
Set FL2 = Worksheets(4)

Worksheets(4): C'est censé etre quelle feuille ?

 

[softimen]

la feuille ou j'ai mis l'exemple ,recap .
desolée j 'ai oublié de modifier ....

 

[vgendron]

bon. avec ce que je devine...

Function inserer(FL2 As Worksheet, lig As Integer, col As Integer)

For j = 19 To 44
    FL2.Cells(col, j) = FL2.Cells(col, j) & FL2.Cells(lig, j)
Next j

End Function

Sub grouper()
Application.ScreenUpdating = False
Dim FL2 As Worksheet, i As Integer, j As Integer, h As String, lig As Integer, col As Integer
Set FL2 = ActiveSheet 'Worksheets(4)
With FL2
    FinFeuille = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = FinFeuille To 10 Step -1
        For j = FinFeuille - 1 To 9 Step -1
            'si les colonnes BCDEF de la ligne i sont identiques
            If ((.Cells(i, 2) Like .Cells(j, 2)) And (.Cells(i, 3) Like .Cells(j, 3)) And (.Cells(i, 4) Like .Cells(j, 4)) And (.Cells(i, 5) Like .Cells(j, 5))) Then
                col = j 'le nom de la varialbe "Col" est quand meme très mal choisi.. vu qu'il s'agit aussi d'un numéro de ligne..
                lig = i
                h = inserer(FL2, lig, col) 'le nom "inserer" prête à confusion, puisqu'il s'agit plutot de fusionner deux lignes....
                Rows(i).Delete
                i = i - 1
            End If
        Next j
    Next i
End With
Application.ScreenUpdating = True
End Sub

 

[softimen]

merci pour ton aide mais ça ne fonctionne pas

 

[vgendron]

Désolé, mais si tu souhaites de l'aide.. la moindre des choses, c'est de répondre aux questions qu'on te pose.
On n'est pas dans ta tete, et on ne peut pas deviner ce que tu souhaites..
donc. pas de réponse. plus de réponse..

 

[softimen]

Bonjour ,
Merci pour votre effort pour résoudre mon problème.
Désolée que je n'ai pas bien expliquée comme je suis nouvelle sur le forum.

Je vous joindre mon fichier avec mon souci ;
La macro se trouve dans le module 5 pour l'appliquer sur la feuille Recap.
Elle fonctionne que si les lignés qui se répètent sont éparpillé sauf si il sont en bloc , elle fusionne que 2 lignes .
Dans l'attente de votre aide .
Merci beaucoup .
Je reste a votre dis potion pour plus d'informations .

 

[vgendron]

Bonjour
On progresse..
avec les données du fichier posté, et le code que j'ai mis dans le module 1, il me semble que ca donne le résultat attendu..
clic sur le bouton "Grouper" en haut de ton tableau

Question: Comment remplis tu ton tableau justement?
je vois que les colonnes N à R sont préremplies avec une formule jusqu'en bas du fichier.. avec une MFC pour colorer une ligne sur deux...ca prend de la place pour rien. et surtout. pas facile à voir..et ca grossit le fichier inutilement
regarde la feuille "Recap(2)" pour une solution avec "Table Excel")

 

[softimen]

Bonjour,
Merci tout d'abord pour votre réactivité !! On progresse en effet.
Je me rends compte que ma demande n'est pas très explicite et qu'il ne doit en effet pas être facile de décoder ma demande (mais elle est claire dans ma tête )

• Pour commencer, mon tableau est alimenté par un autre tableau. Ses valeurs ne sont pas saisies mais importés d'un autre tableau. Il y a ainsi de nombreuses lignes

• Il s'agit ensuite de regrouper les lignes qui ont des valeurs identiques en colonnes B+C+D+E
  • Regroupement sur une seule ligne des contenus des colonnes B+C+D+E qui sont identiques
    
  • Regroupement sur une seule ligne des contenus des colonnes S à AR en fusionnant les contenus s'ils sont dans la même colonne

Ma démarche a été de faire une boucle et de faire un test sur les contenus des colonnes B+C+E+D. Si ces contenues sont identiques, je recopie les valeurs dans les lignes du dessus puis j'efface la ligne en cours.

Je pense en effet que ta proposition de code est proche de ce que je souhaite faire mais il y a un problème au niveau de la suppression de ligne : le regroupement s'effectue mais les lignes non regroupables sont supprimées.
Je te joins un nouveau fichier exemple pour t'illustrer ce que je cherche à faire :

• Des lignes 9 à 21, une idées de lignes telle qu'on pourrait les avoir importées

• Des lignes 30 à 35, les lignes telles qu'on voudrait les avoir regroupées.

J’espère cette fois -ci ,j'ai bien expliquée le problème.

Je vous remercie énormément pour votre aide .

 

[vgendron]

Essai avec ce code donc.

Function fusionner(FL2 As Worksheet, FromLigne As Integer, ToLigne As Integer)

For j = 19 To 44 'pour les colonnes S à AR
    If FL2.Cells(FromLigne, j) <> "" Then 's'il y a quelque chose à recopier à partir de la ligne "FromLigne"
        FL2.Cells(ToLigne, j) = FL2.Cells(ToLigne, j) & FL2.Cells(FromLigne, j)
    Else
        FL2.Cells(ToLigne, j) = FL2.Cells(ToLigne, j)
    End If
Next j

End Function

Sub grouper()
Application.ScreenUpdating = False
Dim FL2 As Worksheet, i As Integer, j As Integer, h As String, FromLigne As Integer, ToLigne As Integer
Set FL2 = ActiveSheet 'Worksheets(4)
With FL2
    FinFeuille = .Range("B" & .Rows.Count).End(xlUp).Row 'récupère la dernière ligne du tableau
    For i = FinFeuille To 10 Step -1 'pour chaque ligne en partant du BAS
        For j = i - 1 To 9 Step -1 'pour chaque ligne au dessus de la ligne i en cours
            'si les colonnes BCDEF de la ligne i sont identiques
            If ((.Cells(i, 2) Like .Cells(j, 2)) And (.Cells(i, 3) Like .Cells(j, 3)) And (.Cells(i, 4) Like .Cells(j, 4)) And (.Cells(i, 5) Like .Cells(j, 5))) Then
                ToLigne = i 'le nom de la varialbe "Col" était quand meme très mal choisi.. vu qu'il s'agit aussi d'un numéro de ligne..
                FromLigne = j
                h = fusionner(FL2, FromLigne, ToLigne) 'le nom "inserer" prête à confusion, puisqu'il s'agit plutot de fusionner deux lignes....
                Rows(j).ClearContents
                'i = i - 1
            End If
        Next j
    Next i
    .Range("B9:B" & FinFeuille).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub

 

[vgendron]

sinon. il y a celui ci. qui est beaucoup plus rapide..

Sub grouper2()
Application.ScreenUpdating = False
Dim tablo() As Variant
With Sheets("RECAP")
    Fin = .UsedRange.Rows.Count
    tablo = .Range("A9:AR" & Fin).Value
End With

For i = LBound(tablo, 1) To UBound(tablo, 1)
    tablo(i, 1) = tablo(i, 2) & tablo(i, 3) & tablo(i, 4) & tablo(i, 5)
Next i
For i = LBound(tablo, 1) To UBound(tablo, 1) - 1
    For j = i + 1 To UBound(tablo, 1)
        If tablo(i, 1) = tablo(j, 1) Then
            For k = 19 To 44
                If tablo(j, k) <> "" Then 's'il y a quelque chose à recopier à partir de la ligne "FromLigne"
                    tablo(i, k) = tablo(i, k) & Chr(10) & tablo(j, k)
'                Else
'                    FL2.Cells(ToLigne, j) = FL2.Cells(ToLigne, j)
                End If
            Next k
            tablo(j, 2) = ""
        End If
    Next j
Next i

For i = LBound(tablo, 1) To UBound(tablo, 1)
    tablo(i, 1) = ""
Next i

With Sheets("Recap")
    .UsedRange.Offset(8, 0).ClearContents
    .Range("A9").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
    .Range("B9:B" & Fin).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub