Microsoft 365 Copier-coller dans une plage avec des cellules masquées

[iliess]

Bonjour,
Je vous transmets un code qui permet de copier-coller dans des cellules filtrées d'une plage contenant des cellules masquées.
Pourriez-vous, s’il vous plaît, l’améliorer ou le modifier afin de le rendre plus rapide et performant, sachant que ma plage de données est très étendue ?
Je vous remercie par avance pour votre aide.
Cordialement.

Sub RemplirDictionnaireVisible()
    Dim Disco1 As Object  ' Déclare un objet dictionnaire
    Dim Cellule As Range  ' Déclare une variable pour chaque cellule dans la plage
    Dim Plage As Range    ' Déclare la plage de cellules à parcourir

    ' Créer un objet dictionnaire
    Set Disco1 = CreateObject("Scripting.Dictionary")

    ' Définir la plage de cellules à analyser
    Set Plage = Range("C2:C19")  ' Plage de A1 à A20

    ' Parcourir chaque cellule de la plage
    For Each Cellule In Plage
        ' Vérifier si la cellule est visible (pas masquée)
        If Not Cellule.EntireRow.Hidden And Not Cellule.EntireColumn.Hidden Then
            ' Ajouter au dictionnaire : clé = adresse de la cellule, valeur = contenu de la cellule
            Disco1(Cellule.Address) = Cellule.Value
        End If
    Next Cellule


    ' Définir la nouvelle colonne (par exemple colonne B)
    NouvelleColonne = "A"
For Each Cle In Disco1.Keys
    ' Extraire uniquement le numéro de ligne de l'adresse
    Dim Ligne As String
    Ligne = Replace(Cle, "$", "") ' Enlever les signes "$" pour garder "A1"
    Ligne = Mid(Ligne, 2) ' Garder uniquement la partie ligne après la lettre de la colonne
    
    ' Construire l'adresse avec la nouvelle colonne
    Range(NouvelleColonne & Ligne).Value = Disco1(Cle)
Next Cle
    ' Libérer le dictionnaire
    Set Disco1 = Nothing
End Sub

 

[sylvanu]

Bonjour Iliess,
Essayez cette macro :

Sub EssaiCopierColler()
    Dim L%
    Application.ScreenUpdating = False
    For L = 2 To 1000   ' A adapter
        If Not Cells(L, "A").EntireRow.Hidden And Not Cells(L, "A").EntireColumn.Hidden Then
            Cells(L, "A") = Cells(L, "C")
        End If
    Next L
End Sub

Sur 1000 lignes avec mon vieux XL2007 je passe de 89ms à 54ms (-40%).
A tester grandeur nature.

 

[sylvanu]

Ou encore avec :

Sub EssaiCopierColler()
    Dim T, L%
    T = [A1:C1000]
    If Not Columns(1).Hidden Then
        For L = 2 To 1000   ' A adapter
            If Not Rows(L).Hidden Then
                T(L, 1) = T(L, 3)
            End If
        Next L
    End If
    [A1].Resize(UBound(T, 1), 1) = T
End Sub

Pus rapide, on passe de 89ms à 31ms ( -65% )

 

[iliess]

Bonjour.
Merci. M. sylvanu.
J'ai remarqué que le résultat dans la feuille C est rapide, mais les valeurs sont toutes Nr "la valeur de la cellule A1".

 

[sylvanu]

Re,
Sur ma PJ ça marche, et le résultat est identique à la feuille B. Voir PJ.
Sur quel fichier travaillez vous ?

 

[iliess]

Dans ma version Excel Office 365, il faut enlever le filtre pour que ça marche.
Merci beaucoup, M.

 

[sylvanu]

Re,
Dans ce cas, il suffit de rajouter :

If Columns("A:C").AutoFilter = False Then Columns("A:C").AutoFilter

et ce sera automatique.