Extraction de données par une macro

Fermé

Christouf1542 Messages postés 15 Date d'inscription mercredi 2 janvier 2019 Statut Membre Dernière intervention 26 octobre 2020 - 4 janv. 2019 à 12:24
Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 - 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.

A voir également:

Extraction de données par une macro
Macro word - Guide
Macro logiciel - Télécharger - Organisation
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Macro recorder - Télécharger - Confidentialité
Effacer les données de navigation - Guide

1 réponse

Réponse 1 / 1

Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 776
Modifié le 4 janv. 2019 à 17:49

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

Reporter valeur sur autre feuille avec critere

Exemple de base de données access

Germain

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

Discussions similaires

Newsletters