VBA Copier cellules selon critère

Bonjour à tous,

Je suis bloqué sur VBA Excel en tentant de réaliser un code. Je possède un fichier avec des données en 'Feuill2' (feuille source). J'aimerais alors copier coller en 'Feuill1' seulement les lignes qui ont en colonne A de la feuille source le mot 'OUI'. Aussi j'aimerais ne copier que certaines des données et non pas toute la ligne, c'est-à-dire seulement les infos des intitulés de la Feuill2.

Je ne sais pas si j'ai été assez clair, mais j'ai mis un exemple du résultat dans le fichier en pj (Feuill1).

8classeur1.xlsx (11.87 Ko)

Merci énormément,

Bonjour matmar77, le forum,

Un essai....

Sub test()
 Dim tablo(), tabloR(), dl As Integer, plage As Range

 Application.ScreenUpdating = False

 With Sheets("Feuil2")                                                'feuille source: à  adapter
            dl = .Range("A" & Rows.Count).End(xlUp).Row
     Set plage = .Range("A2:J" & dl)
         tablo = plage
             k = 0
         For i = 1 To UBound(tablo, 1)
          ReDim Preserve tabloR(1 To 4, 1 To k + 1)
           If tablo(i, 1) = "OUI" Then
            tabloR(1, k + 1) = tablo(i, 2)                            'code valeur
            tabloR(2, k + 1) = tablo(i, 5)                            'libellé valeur
            tabloR(3, k + 1) = tablo(i, 9)                            'libellé pays
            tabloR(4, k + 1) = tablo(i, 10)                           'devise valeur
             k = k + 1
           End If
         Next i
 End With

 With Sheets("Feuil1")                                               'feuille destination: à adapter
       On Error Resume Next
       .Cells.Delete
       .Range("A1") = "CODE VALEUR": .Range("A1").Font.Bold = True
       .Range("B1") = "LIBELLE VALEUR": .Range("B1").Font.Bold = True
       .Range("C1") = "LIBELLE PAYS": .Range("C1").Font.Bold = True
       .Range("D1") = "DEVISE VALEUR": .Range("D1").Font.Bold = True
       .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(tabloR, 2), 4) = Application.Transpose(tabloR)
       .Columns("A:D").AutoFit                                       'ajuste la largeur des colonnes : facultatif
       Erase tabloR
 End With
End Sub
1matmar77.xlsm (17.74 Ko)

CTRL + e pour exécuter la macro

Cordialement,

Re,

Une variante...

Sub test()
 Dim dl As Long

  Application.ScreenUpdating = False

   With Sheets("Feuil2")                                           'feuille source: à adapter
    dl = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:J" & dl).AutoFilter field:=1, Criteria1:="OUI"      'filtre la colonne A : critère= OUI
    .Range("A1:J" & dl).SpecialCells(xlVisible).Copy Sheets("FEUIL1").Range("A1") 'copie lignes filtrées sur feuille destination (nom à adapter)
     If .FilterMode = True Then .ShowAllData                       'supprime le filtre
   End With

   With Sheets("Feuil1")
    .Range("A:A,C:C,D:D,F:F,G:G,H:H").Delete Shift:=xlToLeft       'supprime les colonnes non désirées
    .Columns("A:D").AutoFit: .Range("A1:D1").Font.Bold = True      'ajuste largeur colonne + titre en gras
   End With
  Application.ScreenUpdating = True
End Sub

Cordialement,

Rechercher des sujets similaires à "vba copier critere"