Extraction de données par une macro

Christouf1542 Messages postés 15 Date d'inscription Statut Membre Dernière intervention -
Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention - 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

A voir également:

Extraction de données par une macro
Fuite données maif - Guide
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Supprimer les données de navigation - Guide
Trier des données excel - Guide
Jitbit macro recorder - Télécharger - Confidentialité

1 réponse

Réponse 1 / 1

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780

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/

Discussions similaires

Erreur la zone de données passée à un appel système est insu

Barre de données en pourcentage (maintenir 100% comme max)

je tombe sur le service de diffusion des donnees?que faire?

Transformer un chiffre en lettres dans excel sans macro

Votre réponse

Discussions similaires