Extraction de données par une macro Fermé

Question

Bonjour, 

Dans un fichier Excel, j'ai une feuille "Base" qui comprend les colonnes suivantes :
A : Titre
B : Note
C : Réalisateur
D : Acteurs

Dans une autre feuille, "Top Films", j'aimerais avoir uniquement les films dont la note est égale ou supérieure à 18.

Pour se faire, j'ai bricolé la macro suivante mais celle-ci fait grandement mouliner mon ordinateur : 
Sub Top17()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "17" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub

Sub Top16()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "16" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top15()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "15" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top14()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "14" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top13()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "13" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top12()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "12" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top11()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "11" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top10()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "10" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top9()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "9" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top8()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "8" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top7()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "7" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top6()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "6" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top5()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "5" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top4()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "4" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top3()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "3" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top2()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "2" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top1()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "1" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub Top0()
Dim i As Integer
With ThisWorkbook.Sheets("Top Films")
For i = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
 If .Range("B" & i).Value = "0" Then
                                   .Rows(i).Delete
                        End If
            Next i
End With
End Sub
Sub TopCC()
'
' TopCC Macro
'

'
    Columns("A:B").Select
    Selection.Copy
    Sheets("Top Films").Select
    Range("A1").Select
    ActiveSheet.Paste
End Sub
Sub TopTri()
'
' TopTri Macro
'

'
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("A:B").Select
    Range("B1").Activate
    ActiveWorkbook.Worksheets("Top Films").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top Films").Sort.SortFields.Add Key:=Range( _
        "B2:B3270"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Top Films").Sort
        .SetRange Range("A1:B3270")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Sub MacroTopFilms()
Call TopCC
Call Top17
Call Top16
Call Top15
Call Top14
Call Top13
Call Top12
Call Top11
Call Top10
Call Top9
Call Top8
Call Top7
Call Top6
Call Top5
Call Top4
Call Top3
Call Top2
Call Top1
Call Top0
Call TopTri
End Sub

Existe-t-il un moyen de la simplifier ???
Merci beaucoup par avance !! 
Bien à vous.

Patrice33740 · Answer

Re,

Il suffit d'utiliser un filtre élabore :
Sub TopFilms()
Dim d As Range        'données
Dim c As Range        'critères

Set d = Worksheets("Base").Range("a2").CurrentRegion
  Set c = Worksheets("Critères").Range("a1").CurrentRegion
  ' Effacer le top films précédent
  Worksheets("Top Films").Range("a2").CurrentRegion.Offset(1).Clear
  ' Mettre en place le top films
  If Worksheets("Base").FilterMode Then Worksheets("Base").ShowAllData
  d.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=c, Unique:=False
  d.Copy Destination:=Worksheets("Top Films").Range("a2")
  If Worksheets("Base").FilterMode Then Worksheets("Base").ShowAllData
  ' Trier les notes
  With Worksheets("Top Films")
   .Range("A2").CurrentRegion.Sort Key1:=.Range("B3"), Order1:=xlDescending, Header:=xlYes
   .Range("A2").CurrentRegion.EntireColumn.AutoFit
  End With

End Sub
Ton fichier : https://mon-partage.fr/f/AN6Q1NoT/

Extraction de données par une macro

1 réponse

Discussions similaires