Microsoft 365 Copie de cellules non adjacentes en Vba

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

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

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