Microsoft 365 Copie de cellules non adjacentes en Vba

[Thierry054]

Bonjour,
Je suis tout nouveau sur ce forum et débutant en Vba.
J'ai tenté de trouver la réponse à mon problème dans le forum et sur le net mais je n'ai pas trouvé de solution qui me permette de le résoudre.
Je vous joins mon fichier exemple pour lequel un collègue m'a déjà aidé sur la macro.
Il comporte 2 feuilles :
- la feuille 1 est la source des données
- la feuille 2 est celle dans laquelle copier les données.

Je souhaite, pour chaque ligne qui comporte un caractère en colonne H copier les données présentes en colonnes A, B, F, G.
Ma macro fonctionne pour recopier toutes les colonnes mais je ne trouve pas comment faire pour ne copier que les colonnes ci-dessus...

 

[cp4]

Bonjour,

à tester

Option Explicit

Sub transfert()
   Dim dl As Integer, i As Integer, L As Integer

   dl = ThisWorkbook.Worksheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row

   With ThisWorkbook.Worksheets("Feuil2")
      .UsedRange.Clear
      'ligne d'entete colonnes A, B, F, G.
      .Cells(1, 1) = Worksheets("Feuil1").Cells(1, 1)
      .Cells(1, 2) = Worksheets("Feuil1").Cells(1, 2)
      .Cells(1, 3) = Worksheets("Feuil1").Cells(1, 6)
      .Cells(1, 4) = Worksheets("Feuil1").Cells(1, 7)

      'lignes de données avec condition sur colonne H
      L = 2
      For i = 2 To dl
         If Worksheets("Feuil1").Cells(i, 8) = "x" Then
            .Cells(L, 1) = Worksheets("Feuil1").Cells(i, 1)
            .Cells(L, 2) = Worksheets("Feuil1").Cells(i, 2)
            .Cells(L, 3) = Worksheets("Feuil1").Cells(i, 6)
            .Cells(L, 4) = Worksheets("Feuil1").Cells(i, 7)
            L = L + 1
         End If
      Next i
   End With
Msgbox "terminé!"
End Sub

 

[mapomme]

Bonjour @Thierry054 et bienvenue sur XLD ,
Bonjour @cp4 ,

Une autre manière de faire. Le code dans Module1 est commenté.
Cliquez sur le bouton Hop!

 

[Thierry054]

Bonjour,
Un grand merci à vous deux, cp4 et mapomme, ça fonctionne parfaitement avec vos solutions, avec une vitesse d'exécution hallucinante
En copiant ligne à ligne les celulles des colonnes AB puis FG via mon ancienne macro, cela me prend un temps fou car ma vraie feuil1 contient plus de 20000 lignes !

mapomme, tes commentaires m'ont permis de comprendre comment fonctionne ta procédure : MERCI !

J'ai essayé de modifier votre code pour simplifier ce traitement qui devra être effectué par d'autres personnes que moi.
Je m'explique :
Les colonnes A à G de la Feuil1 contiennent des données qui me sont communiquées telles quelles.
Je sais que je dois travailler sur les lignes dont le prix a évolué et qui sont identifiables par leur couleur de police rouge en colonne G. J'ai contourné le problème en ajoutant une colonne H qui me permet d'identifier cela mais cela suppose une intervention humaine sur cette feuille, intervention que je ne maitriserai pas lorsqu'un tiers le fera.
J'ai donc essayé de modifier la condition "If t(i, 8) <> "" Then" en "If t(i, 7).Font.Color = RGB(255, 0, 0)" mais bien entendu cela ne fonctionne pas car je suppose que le tableau chargé en t ne conserve pas de trace des formats.
Y a t-il une solution pour contourner ce problème et conserver cette vitesse d'exécution ?

 

[mapomme]

Y a t-il une solution pour contourner ce problème et conserver cette vitesse d'exécution ?

Question intéressante - on y réfléchit ...

 

[mapomme]

Re,

Pas certain d'avoir tout compris. J'ai considéré que :

• Si le prix HT de la colonne C est différent du prix HT de la colonne D alors les prix seront considérés comme ayant évolués
• Comme les prix HT ont un nombre de décimales "fantaisiste", on a arrondi les prix HT à deux décimales pour faire les comparaisons

On a donc supprimé le problème de la couleur de police et de la colonne H dont on ne se sert plus. Les commentaires ont été modifiés en conséquence.

A vous de dire si c'est ce que vous souhaitez...

 

[Phil69970]

Bonjour à tous

Une autre version un peu moins rapide mais sur la couleur de la colonne G

identifiables par leur couleur de police rouge en colonne G.

Merci de ton retour

@Phil69970

 

[Thierry054]

Merci à vous deux,
Vos solutions respectives fonctionnent parfaitement.
Celle de mapomme est un peu plus rapide et celle de Phil69970, bien qu'un peu plus lente est basée sur la couleur de la police pour détecter les lignes à copie.
Je n'ai que l'embarras du choix et surtout, je commence à comprendre comment m'y prendre pour rendre mes macros plus efficaces.
Un grand merci à vous deux !!!

 

[mapomme]

je commence à comprendre comment m'y prendre pour rendre mes macros plus efficaces.

C'est aussi à cela que sert le forum, on a en tous bénéficié et on renvoie l'ascenseur .
A plus .

 

[bsalv]

encore 2 versions, celle avec autofilter(ma préférée) maintient les formats originaux de la source (!)
le nombre de lignes est trop petit pour savoir quelque chose concernant la vitesse des macros.

Sub Avec_Index()
     Dim c, aA, aOut, Fl, i, t
     t = Timer

     With Sheets("Feuil1")
          aA = .Range("A1").CurrentRegion    'cette plage
          Set c = .Range(.Range("G1"), .Range("G" & Rows.Count).End(xlUp))     'cette plage en colonne G
          ReDim aOut(1 To c.Rows.Count)      'créer tableau
          For i = 1 To c.Rows.Count          'boucle les cellules
               aOut(i) = IIf(c.Cells(i, 1).Font.Color = vbRed Or i = 1, i, "~")     'marquer dans le tableau les cellules rouges avec "1"
          Next
          Fl = Filter(aOut, "~", 0)
     End With

     With Sheets("Feuil2")
          .UsedRange.Clear                   'Efface tout sur feuille 2
          .Range("A1").Resize(UBound(Fl) + 1, 4) = Application.Index(aA, Application.Transpose(Fl), Array(1, 2, 6, 7))     'copier et coller
          '.Range("A1").CurrentRegion.EntireColumn.AutoFit
     End With
   
     MsgBox "prêt en " & Format(Timer - t, "0.00\s")

End Sub

Sub Avec_Autofilter()
     Dim c, aOut, i, t
     t = Timer

     Dim WS2: Set WS2 = Sheets("Feuil2")
     WS2.UsedRange.Clear                     'Efface tout sur feuille 2
     With Sheets("Feuil1")
          If .AutoFilterMode Then .AutoFilterMode = False     'remettre à zéro autofilter éventuel dans cette feuille
       .Columns("C:E").Hidden = True     'cacher colonnes
         
          Set c = .Range(.Range("G2"), .Range("G" & Rows.Count).End(xlUp))     'cette plage en colonne G
          ReDim aOut(1 To c.Rows.Count, 1 To 1)     'créer tableau
          For i = 1 To c.Rows.Count          'boucle les cellules
               aOut(i, 1) = -(c.Cells(i, 1).Font.Color = vbRed)     'marquer dans le tableau les cellules rouges avec "1"
          Next

          c.Offset(, 1).Value = aOut         'coller le tableau en colonne H
          With .Range("A1").CurrentRegion    'cette plage
               .AutoFilter 8, 1              'autofilter valeur 1 en colonne G
               .Resize(, 7).Copy WS2.Range("A1")     'copier et coller
               .AutoFilter                   'supprimer filtre
          End With
          .Columns("C:E").Hidden = False     'montrer colonnes
     End With
     WS2.Range("A1").CurrentRegion.EntireColumn.AutoFit
     MsgBox "prêt en " & Format(Timer - t, "0.00\s")
End Sub

 

[mapomme]

Re,

le nombre de lignes est trop petit pour savoir quelque chose concernant la vitesse des macros.

Pour le fun...
Un classeur avec une initialisation à 400 000 lignes de données pour faire les tests.
J'y ai inclus les deux macros de @bsalv que je salue .
C'est la macro Avec_Autofilter() qui semble être la plus longue. En fait la copie des cellules visibles aboutit à un nombre important de plages disjointes à copier. C'est à mon avis ce qui ralentit le processus.

 

[bsalv]

bonjour mapomme et salue,
c'était comparer des pommes avec des poires. Mes macros regardaient au couleur de font de la colonne G

2 variantes d'une nouvelle macro, l'une regarde le font de G, l'autre compare C avec D. Conclusion : la vérification du font sur 400.000 cellules coût 4 sec supplémentaire. Ma version sans vérification du font est maintenant légèrement plus vite que la vôtre. (miniscule sur 400.000 lignes)

Je me rapelle plus exactement, mais il y a quelque chose avec 16k ou 32k areas qui cause des problèmes.

 

[RyuAutodidacte]

Bonjour le fil,
@mapomme : j'aimerai proposer une autre solution avec les indications données en post#6 :

Si le prix HT de la colonne C est différent du prix HT de la colonne D alors les prix seront considérés comme ayant évolués
Comme les prix HT ont un nombre de décimales "fantaisiste", on a arrondi les prix HT à deux décimales pour faire les comparaisons

PS : je suis sur Mac
j'ai testé ton code et pour initialisation des lignes (40 000) le résultat et d'environ 80 000
Peux tu me dire si j'ai loupé qq chose … ?

En attendant je vais vous partagé ce que j'ai fait dont le codage est différent en partie :

Sub TestCopie() 'Ryu
Dim deb, Lig, Col, V, i as long, VA

    deb = Timer
 
    Lig = Array(1)
    Col = Array(1, 2, 6, 7)
    With Sheets("Feuil1").Cells(1).CurrentRegion
        V = .Value
        For i = 2 To UBound(V)
            If Round(V(i, 3), 2) <> Round(V(i, 4), 2) Then
                ReDim Preserve Lig(LBound(Lig) To UBound(Lig) + 1)
                Lig(UBound(Lig)) = i
            End If
        Next
        Lig = Application.Transpose(Lig)
        VA = Application.Index(V, Lig, Col)
    End With
 
Application.ScreenUpdating = False
    With Sheets(2)
        .Columns("A:D").ClearContents
        .Cells(1).Resize(UBound(VA), UBound(VA, 2)).Value = VA
    End With
Application.ScreenUpdating = True
 
    [J12] = Timer - deb
    MsgBox "C'est fini en : " & Format([J12], "#0.00\ sec.")

End Sub

PS : le temps d'exécution est différent sur Mac (Excel plus optimisé pour PC)
Utilisation du fichier en Post#11

 

[mapomme]

Bonsoir @RyuAutodidacte,

A vue de nez, ton code est OK si ce n'est le Transpose qui en VBA est limité à 65 536 éléments.

 

[RyuAutodidacte]

Bonsoir @RyuAutodidacte,

A vue de nez, ton code est OK si ce n'est le Transpose qui en VBA est limité à 65 536 éléments.

Re @mapomme
La limitation du transpose c'est ok je la connait (je pourais remplacer le remplacer directement par un tableau 2D) …,
mais comme dans le fichier on est sur 40 000 lignes …
je ne comprends pas pourquoi sur Mac j'ai eu un résultat d'environ 80 000 lignes quand j'ai testé ton code ?
et là je me dis, j'espère que c'est pas un bug avec vba sur Mac (ce qui serait bien la 1ère fois pour une macro de ce genre)
Sur mon résultat j'étais tombé sur environ 15 000 lignes si je me souviens.
si y a un hic je pourrais le corriger, ou alors j'ai bug et la c'est pas top