Mise en regard des données

Bonjour,

voilà j'ai un fichier avec des données qui ne sont pas triées dans la feuille1 et dans la feuille 2 j'aimerais qu'elles soient de cette manière

en sachant que la colonne de référence est la colonne C en fait mettre à la suite les critères

je vous joins le fichier d'essai

D'avance merçi

Jacques

bonjour,

une proposition (vite faite), sélectionner la feuille et lancer la macro). les modifications se font sur la feuille sélectionnée (prendre éventuellement une copie avant).

Sub aargh()
    dl = Cells(Rows.Count, 1).End(xlUp).Row
    i = 1
    Do While i < dl
        dlg = Cells(i, 2).End(xlDown).Row
        Cells(dlg + 1, "i").Resize(dlg - i + 1, 10).Copy Cells(i, "i")
        i = dlg + (dlg - i) + 2
    Loop
    ddl = dl
    For i = dl To 1 Step -1
        If Cells(i, 2) = "" Then Rows(i).Delete
    Next i
End Sub

Bonjour h2so4

merçi pour ton aide mais ça ne fonctionne pas

je te remets un essai en fichier toujours dans la feuille 1 les données brutes et dans la feuille 2 les données comme elles devraient etre

encore merçi

re-bonjour,

merçi pour ton aide mais ça ne fonctionne pas

c'est normal, ta feuille n'a pas la même structure que dans le fichier que tu as mis dans ton premier message.

une adaptation

Sub MiseEnRegard()
    dl = Cells(Rows.Count, 1).End(xlUp).Row
    i = 2
    Do While i < dl
        dlg = i
        Do While Cells(dlg, 3) <> ""
            dlg = dlg + 1
        Loop
        Cells(dlg, "j").Resize(dlg - i, 10).Copy Cells(i, "i")
        i = dlg + (dlg - i)
    Loop
    ddl = dl
    For i = dl To 1 Step -1
        If Cells(i, 3) = "" Then Rows(i).Delete
    Next i
End Sub

Re

apparement ça fonctionne bien sauf que pour les colonnes éloignées ça ne copie pas par exemple jusqu'à la colonne "AZ"

sinon ça fonctionne sur le principe

re-bonjour,

sauf que pour les colonnes éloignées ça ne copie pas par exemple jusqu'à la colonne "AZ"

J'en ferai part à mon fournisseur de boules de cristal. Comment cela se fait-il qu'elle ne l'ait pas deviné ?

Sub MiseEnRegard()
    dl = Cells(Rows.Count, 1).End(xlUp).Row
    dc = ActiveSheet.UsedRange.Columns.Count
    i = 2
    Do While i < dl
        dlg = i
        Do While Cells(dlg, 3) <> ""
            dlg = dlg + 1
        Loop
        Range(Cells(dlg, "j"), Cells(dlg + dlg - i - 1, dc)).Copy Cells(i, "j")
        i = dlg + (dlg - i)
    Loop
    ddl = dl
    For i = dl To 1 Step -1
        If Cells(i, 3) = "" Then Rows(i).Delete
    Next i
End Sub

Bravo

tout fonctionne bien et merçi pour ton humour

Jacques

Bonsoir h2so4

voilà le fichier a fonctionné correctement mais maintenant il me bloque chaque fois mon classeur excel je te mets un fichier test pour que tu voies d'ou vient le problème il me dit l'objet range a échoué

D'avance Merçi et bonne soirée

Jacques

bonsoir,

ton fichier contient au moins une anomalie et la macro n'est pas prévue pour gérer ce cas, voir lignes 556 et suivantes. Ce problème m'empêche de déterminer le problème que tu rencontres "objet range a échoué"

Bonjour,

oui effectivement il y a souvent ce problème ou il me manque des données "Partants" je vois que si je coupe le fichier à la ligne 555 et que je fais fonctionner la macro , elle fonctionne très bien donc avant de la faire fonctionner il faudra que je vérifie si il ne me manque pas des données

excuse-moi du dérangement

Bon 15 Aout

Jacques

bonjour,

j'ai adapté la macro pour gérer le problème rencontré dans le fichier que tu as mis.

Sub aargh()
    With ActiveSheet
        Set dict = CreateObject("scripting.dictionary")
        dl = .Cells(.Rows.CountLarge, 1).End(xlUp).Row
        dc = .UsedRange.Columns.Count
        For i = 2 To dl
            If .Cells(i, 3) <> "" Then
                If swv = True Then swv = False: dict.RemoveAll
                dict.Add .Cells(i, 2).Value & .Cells(i, 4).Value, i
            Else
                If swv = False Then swv = True
                cle = .Cells(i, 2).Value & .Cells(i, 4)
                If dict.exists(cle) Then
                    .Range(.Cells(i, "J"), .Cells(i, dc)).Copy .Cells(dict(cle), "J")
                End If
                .Cells(i, 3) = ""
            End If
        Next i
        .Cells(1, 3).Resize(dl, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlUp
    End With
End Sub

Bonsoir,

après essai sur trois fichiers différents ça fonctionne mais si il me manque des données "partants" il m'efface les "critères mais c'est un demi mal car ça fonctionne très bien merçi

bonne soirée

Jacques

En tout cas h2so4 un grand merçi de ton aide

Jacques

bonjour,

pour garder les données s'il manque des données "partants"

Sub aargh()
    With ActiveSheet
        Set dict = CreateObject("scripting.dictionary")
        dl = .Cells(.Rows.CountLarge, 1).End(xlUp).Row
        dc = .UsedRange.Columns.Count
        For i = 2 To dl
            If .Cells(i, 3) <> "" Then
                If swv = True Then swv = False: dict.RemoveAll
                dict.Add .Cells(i, 2).Value & .Cells(i, 4).Value, i
            Else
                If swv = False Then swv = True
                cle = .Cells(i, 2).Value & .Cells(i, 4)
                If dict.exists(cle) Then
                    .Range(.Cells(i, "J"), .Cells(i, dc)).Copy .Cells(dict(cle), "J")
                    .Cells(i, 3) = ""
                Else
                .Cells(i, 3) = "&"
                End If
            End If
        Next i
        .Cells(1, 3).Resize(dl, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlUp
        .Cells(1, 3).Resize(dl, 1).Replace "&", "", lookat:=xlWhole
    End With
End Sub

Bonjour h2so4

Super tu es un as

j'ai essayé avec 5 fichiers différents et tout fonctionne bien il garde bien les données critères quand il manque les données partants Merçi Merçi Merçi

Jacques

Bonjour H2so4

j'ai un petit problème je crois que la structure des tableaux on changé ce qui fait que la macro ne fonctionne plus

je te joins un fichier pour voir si tu peux y faire quelque chose sinon tant pis

bonne journée

Jacques

Bonjour h2so4

j'ai trouvé en fait il y a eu un changement dans la structure des nouveaux fichiers mais j'ai réussi après maints essais à tout remettre en ordre

donc tout va bien

excuse-moi

bonne soirée

Jacques

bonjour Berjac,

j'étais persuadé d'avoir envoyé une réponse. Tant mieux si tu as pu régler le problème par toi-même.