Menu

Extraction de données par une macro

Messages postés
12
Date d'inscription
mercredi 2 janvier 2019
Dernière intervention
4 janvier 2019
- - Dernière réponse : Patrice33740
Messages postés
7508
Date d'inscription
dimanche 13 juin 2010
Dernière intervention
14 janvier 2019
- 4 janv. 2019 à 17:48
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.
Afficher la suite 

Votre réponse

1 réponse

Messages postés
7508
Date d'inscription
dimanche 13 juin 2010
Dernière intervention
14 janvier 2019
1619
0
Merci
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/

Cordialement
Patrice
Commenter la réponse de Patrice33740