Copies multiples trop longue

Bonjour,

je viens vers vous car j'ai un blocage ... de copier coller !

J'ai un classeur dans lequel je regroupe certaines données selon une référence (en colonne A) qui permet de "replier" le tableau pour faire 1 ligne par réf. pour simplifier les réunions (fonctionne très bien)

Après coup, je souhaite recopier les valeurs de la ligne source dans les autres lignes ayant la même réf.

J'ai donc fait une macro qui utilise un vloockup et qui marche bien (2-3min d’exécution), par contre la macro efface forcément les formules pour ne recopie que la valeur.

J'ai donc cherché un autre moyen avec find + copy/paste, ce qui donne exactement le résultat voulu, mais étant donné le nombre de colonnes et de lignes , la macro met plus de 45min à s’exécuter ...

Je sèche pour trouver une troisième solution et donc je viens vers vous !

Merci d'avance

Première solution:

Sub recopie()
Dim cellule As Range
Dim unel As Range

On Error GoTo 1

    ActiveSheet.ShowAllData
1
    Cells.Select
    Selection.EntireColumn.Hidden = False
    Range("B3").Select

dLignesuivi = Sheets("Tableau_Suivi").Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each cellule In Range("A1:DZ1")
    If cellule = 1 Then
        For i = 3 To dLignesuivi
        aa = Application.WorksheetFunction.CountIf(Range("A3:A" & i), Range("A" & i))
            If aa > 1 Then
                 Cells(i, cellule.Column) = Application.VLookup(Range("A" & i), Range("A3:DZ" & i), cellule.Column, False)

            End If
        Next
    End If
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Call Hideafterall

MsgBox ("MAJ OK")

End Sub

Deuxième solution:

Sub recopie()
Dim cellule As Range
Dim unel As Range

On Error GoTo 1

    ActiveSheet.ShowAllData
1
    Cells.Select
    Selection.EntireColumn.Hidden = False
    Range("B3").Select

dLignesuivi = Sheets("Tableau_Suivi").Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each cellule In Range("A1:DZ1")
    If cellule = 1 Then
        For i = 3 To dLignesuivi
        aa = Application.WorksheetFunction.CountIf(Range("A3:A" & i), Range("A" & i))
            If aa > 1 Then
                    Set unel = Range("A3:A" & i).Find(Range("A" & i), LookIn:=xlValues, lookat:=xlWhole)
                  Cells(unel.Row, cellule.Column).Select
                  Selection.Copy Destination:=Sheets("TABLEAU_SUIVI").Cells(i, cellule.Column)

            End If
        Next
    End If
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Call Hideafterall

MsgBox ("MAJ OK")

End Sub

Bonjour,

as-tu un fichier-test ?

Bonjour,

Voila un fichier exemple extrêmementsimplifié (le vrai fichier fais + de 60 colonnes sur plusieurs milliers de lignes)

merci d'avance

Bonjour,

Donc en gros tu veux filtrer les lignes donc la ville n'est pas remplie en colonne B ?

Bonjour,

Non je filtre le tableau sur 1ligne par réf pendant mes réunions et à la fin je voudrais que les infos de certaines colonnes se recopient pour les refs identiques quand je clique sur un bouton.

(tu peux essayer les macros du fichier, elles fonctionnent, surtout celle de copier coller, c’est juste beaucoup trop long dans le tableau grandeur nature)

Bonjour,

ce qui te prend du temps c'est

Application.WorksheetFunction.CountIf(Range("A3:A" & i), Range("A" & i))

et les recopies

                  Cells(unel.Row, cellule.Column).Select
                  Selection.Copy Destination:=Sheets("TABLEAU_SUIVI").Cells(i, cellule.Column)

Est-ce que tes données sont bien triées par référence ? tout au moins les lignes "filles" sont bien en-dessous de la ligne-mère ?

Dans ce cas, évite le countif et le vlookup ou find, fais le balayage de haut en bas simplement avec copy

Sub recopie2()

    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    ref = ""
    debut = True
    For i = 3 To Range("A" & Rows.Count).End(xlUp).Row + 1
        If Cells(i, 1) <> ref Then
            If debut Then
                debut = False
            Else
                For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
                    If Cells(1, j) = 1 Then
                        Cells(depuis, j).Copy Destination:=Range(Cells(depuis, j), Cells(i - 1, j))
                    End If
                Next
            End If
            depuis = i
            ref = Cells(i, 1)
        End If
    Next

End Sub

Merci beaucoup ! le temps de traitement passe de 45min à moins de 7 !

Excellent journée à toi !

Nicolas

C'est encore trop !