Tris, suppression, report et calculs en fonction d'un tableau précis

[JBond13600]

Bonjour le Forum,

Il me faudrait une macro me permettant de finaliser un projet.

Celle-ci doit faire apparaître une fenêtre permettant de rentrer une valeur ayant des conséquences sur tout le reste de la procédure.
La suite est une série de tris, de reports de données, de suppressions de lignes, et de calculs en fonction d'un tableau de valeur précis.

En fichier joint, toute la procédure et résultats attendus.

Merci de votre aide et bon bout d'an.

 

[Staple1600]

Bonjour le fil, le forum

Juste de passage ici car angoissé je suis de ne pas avoir de réponse dans ton autre fil
https://www.excel-downloads.com/thr...-plusieurs-fichiers-meme-repertoire.20021607/

Pour ta question, ici, quand tu parles de fenêtre?
Il s'agit:
d'un Userform?
d'un MsgBox?
d'un InputBox?

 

[Staple1600]

Re

Suite malgré mon angoisse toujours présente, voici déjà une macro pour traiter le point f)
(test OK sur le fichier joint)

Sub Test_pointF()
Dim Plage As Range, filtre As Range, Cel As Range, Crit
ActiveSheet.AutoFilterMode = False
Set Plage = ActiveSheet.Range(Cells(1, "J"), ActiveSheet.Cells(Rows.Count, "J").End(xlUp))
Crit = InputBox("Saisir votre valeur", "Choix", 40)
With Plage
    .AutoFilter Field:=1, Criteria1:=">" & Crit
    Set filtre = .SpecialCells(xlCellTypeVisible)
    For Each Cel In filtre
    If Cel.Row > 1 Then
    Cel.Offset(1, 1) = Cel.Offset(1)
    End If
    Next
End With
ActiveSheet.AutoFilterMode = False
End Sub

 

[Staple1600]

Re

Aprés le point F, le point G

Sub Test_PointG()
Dim derl As Long
derl = Cells(Rows.Count, "J").End(xlUp).Row
With Range("L1:L" & derl)
    .FormulaR1C1 = "=IF(OR(AND(RC10>0,RC10=RC11),RC10>40),""X"",1)"
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    .Clear
End With
End Sub

 

[JBond13600]

Yoooooo,

Pas d'angoisse. La vie est belle...

J'essaie de voir çà dès que je retrouve un peu de temps

Bien cordialement.

 

[Staple1600]

Re

Si, si angoisse et re angoisse car tu n'as toujours répondu à mon questionnement existentiel dans le fil que je cite dans le message#2
(Mon angoisse est centrée sur le devenir de la courtoisie en 2018 )

Alors en attendant ta réponse, aprés le point G, le point H jusqu'au point L.
(test Ok sur le fichier exemple)
NB: Il faut au préalable nommer le tableau idoine tablo

Sub test_PointH_a_PointL()
Dim r As Range
For Each c In Columns("K:K").SpecialCells(xlCellTypeConstants, 1)
c.Offset(, 2) = Application.VLookup(c, [tablo], 3, 0)
c.Offset(, 4) = Application.VLookup(c, [tablo], 2, 0)
Next
End Sub

 

[Staple1600]

Re

J'ai regroupé plusieurs points dans une seule macro

Sub test_PointH_a_PointM2_ok()
Dim r As Range
For Each c In Columns("K:K").SpecialCells(xlCellTypeConstants, 1)
c.Offset(, 2) = Application.VLookup(c, [tablo], 3, 0)
c.Offset(, 4) = Application.VLookup(c, [tablo], 2, 0)
c.Offset(, 6) = Cells(c.Row, "G") * Cells(c.Row, "O")
c.Offset(, 8) = Cells(c.Row, "Q") - Cells(c.Row, "M")
Next
End Sub

 

[Staple1600]

Re

Apparemment les festivités ont déjà commencé pour le demandeur

Ce qui n'est pas encore le cas ici

Sub Macro_Tout_en_Un_oupresque()
Dim Plage As Range, filtre As Range, Cel As Range, Crit, r As Range, derl As Long
Application.ScreenUpdating = False
'tri et suppression ligne vide
Columns("B:J").Sort Key1:=Range("J1"), Order1:=xlAscending, Header:=xlGuess
Columns("J:J").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("B:J").Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("D1"), Order2:=xlAscending, Header:=xlGuess
'ajout valeurs
ActiveSheet.AutoFilterMode = False
Set Plage = ActiveSheet.Range(Cells(1, "J"), ActiveSheet.Cells(Rows.Count, "J").End(xlUp))
Crit = InputBox("Saisir votre valeur", "Choix", 40)
With Plage
    .AutoFilter Field:=1, Criteria1:=">" & Crit
    Set filtre = .SpecialCells(xlCellTypeVisible)
    For Each Cel In filtre
    If Cel.Row > 1 Then
    Cel.Offset(1, 1) = Cel.Offset(1)
    End If
    Next
End With
ActiveSheet.AutoFilterMode = False
'suppression ligne
derl = ActiveSheet.Cells(Rows.Count, "J").End(xlUp).Row
With Range("L1:L" & derl)
    .FormulaR1C1 = "=IF(OR(AND(RC10>0,RC10=RC11),RC10>40),""X"",1)"
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    .Clear
End With
'calculs
For Each c In Columns("K:K").SpecialCells(xlCellTypeConstants, 1)
c.Offset(, 2) = Application.VLookup(c, [tablo], 3, 0)
c.Offset(, 4) = Application.VLookup(c, [tablo], 2, 0)
c.Offset(, 6) = Cells(c.Row, "G") * Cells(c.Row, "O")
c.Offset(, 8) = Cells(c.Row, "Q") - Cells(c.Row, "M")
Next
End Sub

 

[JBond13600]

Bonjour le Forum,
Bonjour staple1600,

1er test effectué.

La boite qui apparaît pour entrer une valeur correspond à ce que je voulais.
Par suite, en laissant le valeur 40 et en lançant l'exécution, il m'envoie un message d'erreur :
"Erreur exécution 424
Objet requis"
et c'est ".clear" de la partie "suppression de ligne" qui est surligné en jaune.

Et dans le fichier testé, toutes les données disparaissent.

Cordialement.

 

[Staple1600]

Re

@JBond13600
Avant de te répondre j'attends ta réponse (dans l'autre fil)

Bonjour le fil, le forum

@JBond13600
Est-ce que le message#60 (en d'autres termes, mon premier message dans ton fil) a éclairé ta lanterne?
Ou est-ce que par hasard, affairé par les festivités, tu l'aurais pas simplement zappé?
(Dans ce cas, tu ne serais pas le seul )

NB: je précise que mes macros furent testés avec succès sur ton fichier exemple.
Donc au final, ma réponse est dans mon NB

 

[Staple1600]

Re,

Par acquis de conscience, j'ai revérifié ma dernière macro.
Elle fonctionne correctement si tu respectes les points suivants:
• Tu dois être sur la feuille Feuil1 quand tu la lances
• Et surtout tu dois avoir nommé ton tableau de la feuille Feuille 7, tablo
(Je te laisse regarder les tutoriels pour nommer une plage de cellules)