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).
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
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,