XL 2016 Copier coller données supérieur/inférieur à une valeur

A

AlanAxel

XLDnaute Nouveau
Bonjour le Forum,

Je souhaite à partir d'une macro copier coller des données selon les étapes suivantes :

Étapes déjà réalisées :
1 - À partir de l'onglet "Source", copier les données des cellules D6:E163 et plus (ex. : comme dans le fichier : D6:E1000)
2 - Coller en tri décroissant de la valeur "MONTANT_V" les données dans l'onglet "Resultat" dans les cellules A17:B1000

Étapes à realiser (pour la suite dans l'onglet "Resultat") :
3 - Copier les données de la "TABLE 0" (Cellules A17:B1000) >= à la moyenne (Cellule B5)
4 - Coller les données copiées à l'étape 3, tout en respectant le tri décroissant des montants dans la "TABLE I" (cellules E17:F1000)
5 - Copier les données de la "TABLE 0" (Cellules A17:B1000) < à la moyenne (Cellule B5)
6 - Coller les données copiées à l'étape 5, tout en respectant le tri décroissant des montants dans la "TABLE II" (cellules G17:H1000)

-----STRATE TABLE I------------------------
7 - Copier les données de la "TABLE I" (Cellules D17:E1000) >= à la moyenne (Cellule E5)
8 - Coller les données copiées à l'étape 7, tout en respectant le tri décroissant des montants dans la "STRATE TABLE I" (cellules K17:L1000)
9 - Copier les données de la "TABLE I" (Cellules D17:E1000) < à la moyenne (Cellule E5)
10 - Coller les données copiées à l'étape 9, tout en respectant le tri décroissant des montants dans la "STRATE TABLE I" (cellules N17:O1000)

-----STRATE TABLE II------------------------
11 - Copier les données de la "TABLE II" (Cellules G17:H1000) >= à la moyenne (Cellule H5)
12 - Coller les données copiées à l'étape 11, tout en respectant le tri décroissant des montants dans la "STRATE TABLE II" (cellules Q17:R1000)
13 - Copier les données de la "TABLE II" (Cellules G17:H1000) < à la moyenne (Cellule H5)
14 - Coller les données copiées à l'étape 13, tout en respectant le tri décroissant des montants dans la "STRATE TABLE II" (cellules T17:U1000)

Le résultat final est comme celui présenté à l'onglet "Resultat"

Grand Merci
 

Pièces jointes

  • Docu_test.xlsm
    150.8 KB · Affichages: 5
Trier par date Trier par votes
Calvus

Calvus

XLDnaute Barbatruc
Bonjour AlanAxel, le forum,

Voici ton fichier en retour.

J'ai remplacé ton code de copie par celui-ci, nettement plus court :
VB: 
f1.Range("D6" & ":E" & f1.Range("D" & Rows.Count).End(xlUp).Row).Copy Destination:=f2.Range("A17")

'Tri des données
    f2.Sort.SortFields.Clear
    f2.Sort.SortFields.Add Key:=Range("B17:B" & Range("A" & Rows.Count).End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With f2.Sort
        .SetRange f2.Range("A17" & ":B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
        .Apply
    End With

Pour le reste voici :
Code: 
Option Explicit

Sub Copie()

Dim f1 As Worksheet, f2 As Worksheet, t, a()
Dim i As Integer, n As Integer, moyenne As Long, moyenne2 As Long, moyenne3 As Long
Set f1 = Sheets("Source")
Set f2 = Sheets("Resultat")

f1.Range("D6" & ":E" & f1.Range("D" & Rows.Count).End(xlUp).Row).Copy Destination:=f2.Range("A17")

'Tri des données
    f2.Sort.SortFields.Clear
    f2.Sort.SortFields.Add Key:=Range("B17:B" & Range("A" & Rows.Count).End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With f2.Sort
        .SetRange f2.Range("A17" & ":B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
        .Apply
    End With

'Tri selon supérieur à la moyenne
t = f2.Range("A17" & ":B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
ReDim a(1 To UBound(t), 1 To UBound(t))

moyenne = [B5].Value
For i = 1 To UBound(t)
    If t(i, 2) >= moyenne Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("D17").Resize(UBound(a), 2) = a

'Tri selon supérieur à la moyenne
ReDim a(1 To UBound(t), 1 To UBound(t))

n = 0
For i = 1 To UBound(t)
    If t(i, 2) < moyenne Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("G17").Resize(UBound(a), 2) = a

'Tri selon supérieur à la moyenne2
moyenne2 = [E5].Value
t = f2.Range("A17" & ":B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
ReDim a(1 To UBound(t), 1 To UBound(t))

n = 0
For i = 1 To UBound(t)
    If t(i, 2) >= moyenne2 Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("K17").Resize(UBound(a), 2) = a

'Tri selon supérieur à la moyenne2
ReDim a(1 To UBound(t), 1 To UBound(t))

n = 0
For i = 1 To UBound(t)
    If t(i, 2) < moyenne2 Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("N17").Resize(UBound(a), 2) = a

'Tri selon supérieur à la moyenne3
moyenne3 = [H5].Value
ReDim a(1 To UBound(t), 1 To UBound(t))

n = 0
For i = 1 To UBound(t)
    If t(i, 2) >= moyenne3 Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("Q17").Resize(UBound(a), 2) = a

'Tri selon supérieur à la moyenne3
ReDim a(1 To UBound(t), 1 To UBound(t))

n = 0
For i = 1 To UBound(t)
    If t(i, 2) < moyenne3 Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("T17").Resize(UBound(a), 2) = a
End Sub

En revanche, vérifie bien car je n'obtiens pas les mêmes résultats que toi pour les moyennes inférieures.

A+
 

Pièces jointes

  • Docu_test.xlsm
    167.3 KB · Affichages: 3
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil, AlanAxel

AlanAxel (Bienvenue sur le forum)
Une proposition (jusqu'à l'étape 6, sauf erreur de ma part)
VB: 
Sub test()
Dim f As Worksheet, plg As Range, crit, DL&
Set f = Sheets("Source")
DL = f.Cells(Rows.Count, "E").End(3).Row
Set plg = f.Range("E5:E" & DL)
crit = Round(Application.Average(plg))
f.Range("D4:E" & DL).Copy Sheets("Resultat").[A16]
Sheets("Resultat").Range("A16:B250").Sort Key1:=Sheets("Resultat").Range("B17"), Order1:=xlDescending, Header:=xlYes
f.Range("D4:E" & DL).AutoFilter Field:=2, Criteria1:=">=" & crit, Operator:=xlAnd
f.Columns("F:F").Hidden = True
f.AutoFilter.Range.Copy Sheets("Resultat").[D16]
f.Range("D4:E163").AutoFilter Field:=2, Criteria1:="<" & crit, Operator:=xlAnd
f.AutoFilter.Range.Copy Sheets("Resultat").[G16]
f.Columns("F:F").Hidden = False
f.ShowAllData
f.AutoFilterMode = False
End Sub
Pré-requis
Déplacer ces deux formules , respectivement en D3 et E3 (sur la feuille Source)
=NB(D5:D499)
=SOMME(E5:E499)


EDITION:
Bonjour Calvus
 
Vote positif 0 Vote négatif
A

AlanAxel

XLDnaute Nouveau
Bonjour le forum,

Salutations Calvus et Staple1600. Merci pour la rapidité de vos réponses.

Calvus ta solution fonctionne à merveille. J'ai réécris ton code en définissant "t1" et "t2" et en les attribuant respectivement pour les tables "TABLE I" et "TABLE II". Donc voice ton code réécris pour être adapté à mon fichier. Je profite de l'occasion pour te remercier pour cette aide inestimable.

VB: 
Option Explicit

Sub Copie()
't = Données TABLE 0
't1 = Données TABLE I
't2 = Données TABLE II

Dim f1 As Worksheet, f2 As Worksheet, t, t1, t2, a()
Dim i As Integer, n As Integer, moyenne As Long, moyenne2 As Long, moyenne3 As Long
Set f1 = Sheets("Source")
Set f2 = Sheets("Resultat")

f1.Range("D6" & ":E" & f1.Range("D" & Rows.Count).End(xlUp).Row).Copy Destination:=f2.Range("A17")

'Tri des données TABLE 0 Ordre décroissant
    f2.Sort.SortFields.Clear
    f2.Sort.SortFields.Add Key:=Range("B17:B" & Range("A" & Rows.Count).End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With f2.Sort
        .SetRange f2.Range("A17" & ":B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
        .Apply
    End With

'Copier la borne supérieure des données TABLE 0 vers la TABLE I
t = f2.Range("A17" & ":B" & f2.Range("A" & Rows.Count).End(xlUp).Row)
ReDim a(1 To UBound(t), 1 To UBound(t))

moyenne = [B5].Value
For i = 1 To UBound(t)
    If t(i, 2) >= moyenne Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("D17").Resize(UBound(a), 2) = a

'Copier la borne inférieure des données TABLE 0 vers la TABLE II
ReDim a(1 To UBound(t), 1 To UBound(t))

n = 0
For i = 1 To UBound(t)
    If t(i, 2) < moyenne Then
        n = n + 1
            a(n, 1) = t(i, 1)
            a(n, 2) = t(i, 2)
    End If
Next i
f2.Range("G17").Resize(UBound(a), 2) = a

'Copier la borne supérieure des données TABLE I vers la STRATE TABLE I (K17)
moyenne2 = [E5].Value
t1 = f2.Range("D17" & ":E" & f2.Range("A" & Rows.Count).End(xlUp).Row)
ReDim a(1 To UBound(t1), 1 To UBound(t1))

n = 0
For i = 1 To UBound(t1)
    If t1(i, 2) >= moyenne2 Then
        n = n + 1
            a(n, 1) = t1(i, 1)
            a(n, 2) = t1(i, 2)
    End If
Next i
f2.Range("K17").Resize(UBound(a), 2) = a

'Copier la borne inférieure des données TABLE I vers la STRATE TABLE I (N17)
ReDim a(1 To UBound(t1), 1 To UBound(t1))

n = 0
For i = 1 To UBound(t1)
    If t1(i, 2) < moyenne2 Then
        n = n + 1
            a(n, 1) = t1(i, 1)
            a(n, 2) = t1(i, 2)
    End If
Next i
f2.Range("N17").Resize(UBound(a), 2) = a

'Copier la borne supérieure des données TABLE II vers la STRATE TABLE II (Q17)
moyenne3 = [H5].Value
t2 = f2.Range("G17" & ":H" & f2.Range("A" & Rows.Count).End(xlUp).Row)
ReDim a(1 To UBound(t2), 1 To UBound(t2))

n = 0
For i = 1 To UBound(t2)
    If t2(i, 2) >= moyenne3 Then
        n = n + 1
            a(n, 1) = t2(i, 1)
            a(n, 2) = t2(i, 2)
    End If
Next i
f2.Range("Q17").Resize(UBound(a), 2) = a

'Copier la borne inférieure des données TABLE II vers la STRATE TABLE II (T17)
ReDim a(1 To UBound(t2), 1 To UBound(t2))

n = 0
For i = 1 To UBound(t2)
    If t2(i, 2) < moyenne3 Then
        n = n + 1
            a(n, 1) = t2(i, 1)
            a(n, 2) = t2(i, 2)
    End If
Next i
f2.Range("T17").Resize(UBound(a), 2) = a
End Sub
 

Pièces jointes

  • Docu_test_1.xlsm
    155 KB · Affichages: 2
Vote positif 0 Vote négatif
A

AlanAxel

XLDnaute Nouveau
Staple1600 à dit:
Bonjour le fil,

AlanAxel
Juste pour savoir, mon code il fait quoi?
(Car je suppose que tu l'as testé, ne serait-ce que par courtoisie...)
Cliquez pour agrandir...

Allo Staple1600,

Oui effectivement je l'ai essayé, mais l'adaptation a été beaucoup d'essai-erreur. Je devais définir plusieurs paramètres comme tu peux le voir dans le code ci-dessous. Je l'ai cheminé jusqu'à l'étape 10. J'aurais pu le terminer mais compte tenu des paramètres et des plages de données et comme je devais changez les formules de cellule dans l'onglet source je ne l'ai pas utilisé. J'avoue cependant qu'après la definition des paramètres il est assez facile d'utilisation. avec la technique d'autofiltre... Tout compte fait, étant un newbie, voici comment j'avais commené à l'adapter :
VB: 
Sub test()
Dim f As Worksheet, r As Worksheet, plg As Range, plg1 As Range, plg2 As Range, crit, DL&, LB&, SL&
Set f = Sheets("Source")
Set r = Sheets("Resultat")
DL = f.Cells(Rows.Count, "E").End(3).Row
LB = r.Cells(Rows.Count, "E").End(3).Row
SL = r.Cells(Rows.Count, "H").End(3).Row
Set plg = f.Range("E5:E" & DL)
Set plg1 = r.Range("E16:E" & LB)
Set plg2 = r.Range("H16:E" & SL)
crit = Round(Application.Average(plg))
crit1 = Round(Application.Average(plg1))
crit2 = Round(Application.Average(plg2))

'Remplir table 0
f.Range("D4:E" & DL).Copy Sheets("Resultat").[A16]
Sheets("Resultat").Range("A16:B250").Sort Key1:=Sheets("Resultat").Range("B17"), Order1:=xlDescending, Header:=xlYes

'Remplir Table I et Table II
f.Range("D4:E" & DL).AutoFilter Field:=2, Criteria1:=">=" & crit, Operator:=xlAnd
f.Columns("F:F").Hidden = True
f.AutoFilter.Range.Copy Sheets("Resultat").[D16]
Sheets("Resultat").Range("D16:E1000").Sort Key1:=Sheets("Resultat").Range("E17"), Order1:=xlDescending, Header:=xlYes
'
f.Range("D4:E" & DL).AutoFilter Field:=2, Criteria1:="<" & crit, Operator:=xlAnd
f.AutoFilter.Range.Copy Sheets("Resultat").[G16]
Sheets("Resultat").Range("G16:H1000").Sort Key1:=Sheets("Resultat").Range("H17"), Order1:=xlDescending, Header:=xlYes
f.Columns("F:F").Hidden = False
f.ShowAllData
f.AutoFilterMode = False

'Remplir Strate Table I
r.Range("D16:E" & LB).AutoFilter Field:=2, Criteria1:=">=" & crit1, Operator:=xlAnd
r.Columns("F:F").Hidden = True
r.AutoFilter.Range.Copy Sheets("Resultat").[K16]
Sheets("Resultat").Range("K16:L1000").Sort Key1:=Sheets("Resultat").Range("L17"), Order1:=xlDescending, Header:=xlYes
r.Columns("F:F").Hidden = False

r.Range("D16:E" & LB).AutoFilter Field:=2, Criteria1:="<" & crit1, Operator:=xlAnd
r.Columns("F:F").Hidden = True
r.AutoFilter.Range.Copy Sheets("Resultat").[N16]
Sheets("Resultat").Range("N16:O1000").Sort Key1:=Sheets("Resultat").Range("O17"), Order1:=xlDescending, Header:=xlYes
r.Columns("F:F").Hidden = False

r.ShowAllData
r.AutoFilterMode = False

'Remplir Strate Table II

End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
Microsoft 365 copier coller un tableau
Réponses
11
Affichages
643
BER6543
B
S
  • Résolu(e)
Microsoft 365 Excel recopier des données d'un tableau dans un autre onglet sans macro
Réponses
5
Affichages
516
Sissou71
S
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
320
gwenn49
G
T
  • Question
Microsoft 365 Coller dans une colonne filtrée
Réponses
5
Affichages
633
bitissa
B
S
  • Question
XL 2016 VBA - copier coller des données d'un onglet vers un nouvel onglet
Réponses
1
Affichages
481
vgendron
vgendron
F
  • Question
Microsoft 365 Copier des données en décalant des cellules
Réponses
6
Affichages
176
Frank Bellaisch
F
M
  • Question
Microsoft 365 VBA copier des données d'un classeur à un autre
Réponses
4
Affichages
151
sylvanu
sylvanu
K
  • Résolu(e)
XL 2016 Envoyer un mail en ne choisissant que certaines cellules
Réponses
5
Affichages
321
Kelbret
K
J
  • Question
XL 2019 copier coller par macro
Réponses
5
Affichages
597
Phil69970
Phil69970
P
  • Question
XL 2021 Code VBA pour copier coller des données de cellules d'une feuille a une autre
Réponses
4
Affichages
227
phoceenjo
P

Membres actuellement en ligne

1 membres et 38 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 023
Messages
2 084 715
Membres
102 637
dernier inscrit
TOTO33000