Problème pour coder une macro

Bonjour à tous,

je sollicite votre aide pour m'aider à trouver une solution à un problème que je rencontre sur le fichier ci-joint.

Ca c'est un screen de la feuille 2 :

Et j'aimerais que mon code donne comme sur le screen de la feuille 1 :

C'est à dire pour vous expliquer :

Dans la feuille 2, si la valeur de la ligne en colonne A et en colonne D est identique à une autre valeur de la ligne en colonne A et en colonne D (comme ligne 1,2,3 dans l'exemple) alors dans la feuille 1 le code indique juste une ligne (pour rassembler les 3) avec en colonne E les valeurs de la colonne E de la feuille 2.

Si il y a qu'une seule fois la combinaison de la valeur de la colonne A et D (sur la feuille 2) alors une ligne est créée en feuille 1 (cf. lignes 2 et 3 de la feuille 1).

J'espère avoir été suffisamment précis dans mes explications pour que vous compreniez la problématique (pour info, le fichier est beaucoup plus volumineux que ça en vrai).

J'ai tenté avec qqch du type :

Sub X

Dim M as Integer 

M = 2000

         For i = 1 to M
                 if feuille2.cells(I, 1).Value = feuille2.cells(I + 1, 1).Value then 
                    feuille1.cells(I, 1) = feuille2.cells(I, 1).Value
                endif
       Next i

endsub

C'était déjà pour récupérer A1 de la feuille 2 pour l'envoyer dans la feuille 1.

Mais bon c'est très sommaire et ça ne fonctionne pas (j'ai l'impression que ça fait déjà lagger le PC avec qqs lignes).

Est-ce que qq'un pourrait m'aider s'il vous plaît, je suis dans le flou en fait, et je n'arrive pas à voir comment faire en fait.

Je vous remercie par avance.

Bonjour tout le monde.

Est-ce que qq'un aurait une piste à me partager s'il vous plaÎt, je reste bloqué en fait..

Bonjour,

Essaye cette macro et dis-moi si cela t'aide:

Sub X()

Dim ligneA As Integer
Dim ligneB As Integer
Dim ligneC As Integer
Dim test As Integer

Dim donnéeA As String
Dim donnéeB As String
Dim donnéeC As String
Dim donnéeD As String

M = 1000 'nombre de lignes à tester
Sheets("Feuil2").Copy after:=Sheets(1) ' copie de sécurité de la page
ligneC = 1

Sheets("Feuil2").Activate
For ligneA = 1 To M 'je défini une première ligne
test = 0

donnéeA = Sheets("Feuil2").Cells(ligneA, 1)
donnéeC = Sheets("Feuil2").Cells(ligneA, 4)

For ligneB = ligneA + 1 To M 'je défini une 2ème ligne
donnéeB = Sheets("Feuil2").Cells(ligneB, 1)
donnéeD = Sheets("Feuil2").Cells(ligneB, 4)
    'je vais comparer ma première ligne à toutes les deuxièmes lignes
    If Not IsEmpty(Cells(ligneB, 1)) And donnéeA = donnéeB And donnéeC = donnéeD Then
    ' si c'est bon je copie mes deux premières cases sur la feuille 1
    Sheets("Feuil1").Cells(ligneC, 1) = Sheets("Feuil2").Cells(ligneA, 1).Value
    Sheets("Feuil1").Cells(ligneC, 4) = Sheets("Feuil2").Cells(ligneA, 4).Value
            'pour la troisième case, si la case est vide je copie valeur a et dessous valeur b
            If Sheets("Feuil1").Cells(ligneC, 5) = "" Then
            Sheets("Feuil1").Cells(ligneC, 5) = Sheets("Feuil2").Cells(ligneA, 5).Value & Chr(10) & Sheets("Feuil2").Cells(ligneB, 5).Value
            ' sinon je garde sa propre valeur et en dessous je copie valeur a et en dessous valeur b
            Else
            Sheets("Feuil1").Cells(ligneC, 5) = Sheets("Feuil1").Cells(ligneC, 5).Value & Chr(10) & Sheets("Feuil2").Cells(ligneB, 5).Value
            End If
    ' je met ma valeur test à 1 pour dire que j'ai déjà copié mes valeurs ligneA
    test = 1
    ' et j'efface ma ligneB pour ne pas la retraiter
    Rows(ligneB) = ""
    End If

Next ligneB

                ' quand j'ai traité toutes mes lignesB pour ma ligneA
                ' si j'ai pas copié ma ligneA je la copie 
                If test = 0 Then
                Sheets("Feuil1").Cells(ligneC, 1) = Sheets("Feuil2").Cells(ligneA, 1).Value
                Sheets("Feuil1").Cells(ligneC, 4) = Sheets("Feuil2").Cells(ligneA, 4).Value
                Sheets("Feuil1").Cells(ligneC, 5) = Sheets("Feuil2").Cells(ligneA, 5).Value
                End If
                ' et dans tous les cas, j'en ai fini donc je l'efface
                Rows(ligneA) = ""

    ' si ma ligneC (ligne qui défini ou je colle mes valeurs en fuille1) est remplie, je passe à la suivante
    If Not IsEmpty(Sheets("Feuil1").Cells(ligneC, 1)) Then
    ligneC = ligneC + 1
    End If

Next ligneA

Application.DisplayAlerts = wdAlertsNone 'j'enlève l'alerte car je vais supprimer un onglet

Sheets("Feuil2").Delete ' j'efface ma feuille 2
Sheets("Feuil2 (2)").Name = "Feuil2" ' que je remplace par sa copie de sécurité 
End Sub

Merci beaucoup ZeChris pour ta réponse.

Je viens de tester la macro, mais cela fait tourner en boucle Excel.

J'essaie de voir pourquoi.

Bonjour,

Cette macro te fera ça aux petits oignons.... Pour peu que tu mettes quelque chose en B1 et C1 !

Sub Galopin()
Dim Arr, T, i%, Dec%, S$, Dico
   Set Dico = CreateObject("scripting.dictionary")
   Arr = Feuil2.[A1].CurrentRegion.Value
   i = 1
   Dec = 1
    S = Arr(i, 4) & Chr(124) & Arr(i, 5)
   Do Until i = UBound(Arr)
    If Arr(i + Dec, 1) = Arr(i, 1) Then
        S = S & Chr(10) & Arr(i + Dec, 5)
        Dec = Dec + 1
    Else
    Dico(Arr(i, 1)) = S
        i = i + Dec
        Dec = 1
    S = Arr(i, 4) & Chr(124) & Arr(i, 5)
    End If
   Loop
    Dico(Arr(i, 1)) = S
Feuil1.[A1].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
T = Application.Transpose(Dico.items)
For i = 1 To Dico.Count
Feuil1.Cells(i, 4) = Split(T(i, 1), "|")(0)
Feuil1.Cells(i, 5) = Split(T(i, 1), "|")(1)
Next
End Sub

A+

Merci galopin01, c'est trop cool ça fonctionne :)

Je vais adapter ta structure à mon gros fichier et normalement le pb sera résolu :)

Bonjour Galopin.

Pourrais-tu m'expliquer en deux mots le principe de ta macro s'il te plait ?

Je la comprends pas trop (je suis autodidacte et pas encore très au point, y qu'à voir comme mon code fait ramer le PC de Lafrog )

Merci d'avance

Bonjour,

Ce problème n'a que l'apparence de la simplicité ! Pour coder ça en évitant de faire ramer le PC il n'y a qu'une solution : Ne surtout pas travailler sur les feuilles, mais travailler sur des Array (tableaux) en mémoire. Le travail sur les Array divise le temps de W par 20 : Le travail est exactement le même que sur feuille sauf que les Array n'ont aucune formule, aucun format, donc le processeur n'a pas à s'occuper de toutes les liens entre les propriétés internes liées aux feuilles et aux cellules. Il ne gère que des tableaux avec des lignes et des colonnes et des valeurs dedans. Une fois le tableau rempli

Arr = Feuil2.[A1].CurrentRegion.Value 

YAPUKA parcourir cet Array (Arr) :

Arr(1,1) = Cellule"A1"
Arr(1,2) = Cellule"B1"
Arr(2,1) = Cellule"A2"

Dès lors l'algorithme est le même que si on travaillait sur une feuille :

'On parcoure le tableau (Array)
'Pour charger le Dictionnary au fur et à mesure
i = 1
Dec = 1
S = Arr(i, 4) & Chr(124) & Arr(i, 5)
Do Until i = UBound(Arr)
    If Arr(i + Dec, 1) = Arr(i, 1) Then
        S = S & Chr(10) & Arr(i + Dec, 5)
        Dec = Dec + 1
    Else
        Dico(Arr(i, 1)) = S
        i = i + Dec
        Dec = 1
        S = Arr(i, 4) & Chr(124) & Arr(i, 5)
    End If
   Loop
Dico(Arr(i, 1)) = S

On parcoure et on compare toutes la colonne 1 et si la cellule suivante est identique on génére un Dictionnary dont le principe est encore plus rapide que les Array : Là le gain de temps est encore plus important (on divise encore par 5) car le Dictionnary ne s'occupe pas de tableaux mais il se comporte comme un dictionnaire. C'est la force de cette programmation : on gère un super Larousse de chaînes de caractères séparées par des caractères (ici des pipes Chr(124) = "|" ) La restitution est très simple elle se fait un peu de la même manière que la fonction "Convertir" du ruban "Données"…

'YAPUKA décharger le Dico ou on veut !
Feuil1.[A1].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
T = Application.Transpose(Dico.items)
For i = 1 To Dico.Count
    Cells(i, 4) = Split(T(i, 1), "|")(0)
    Cells(i, 5) = Split(T(i, 1), "|")(1)
Next

Bon c'est un peu complexe, traduire ça au ligne par ligne n'a à mon avis aucun sens car on distingue deux traitements différents la colonne 1 qui récupère les "keys" du Dico : La récupération est très simple 1 seule ligne… Et les données parsées des colonnes 4 et 5 qui passent par un Array intermédiaire (T)

Euh… Toussa c'est 30 ans de pratique résumées en quelques lignes. Ça se digère à dose homéopathique !

A+

Merci beaucoup pour toutes ces informations.

Je vais me prendre un petit doliprane et m’atteler à tout ça. Je vois que j'ai encore une belle marge de progression !

Merci en tous cas d'avoir pris le temps de me répondre. Je vais reprendre ça à tête reposée et essayer de saisir le concept, ce sera déjà je pense un grand pas en avant.

Chaque chose en son temps !!!!! Apprendre à marcher avant de courir.

Au plaisir de te recroiser sur le forum.