Garder seulement les indices 2 ou 3..

[Guido]

Bonsoir le Forum

je reviens vers Vous pour régler un soucis facile..pour Vous,mais pas pour Moi...

Dans une plage N°1 j'ai des lignes avec une colonne contenant des indices divers ..Vide-1-2-3-4-5- ou 6.

J'aimerais garder seulement les lignes qui ont un indice de deux ou trois.

le tableau change tout les jours.

Et ensuite faire affichés les lignes désirées ou restantes dans le tableau finale,

et la de nouveau une élimination..la ou les lignes ayant dans la colonnes partants

un chiffres inférieur a 8 partants , ont élimine aussi.

Je pense que tout peux se faire a partir du tableau N° 1.....

Voir le fichier.,

D'avance Merci

Guido

 

[job75]

Bonjour Guido, le forum,

A placer dans le code de la feuille "REUNIONS" (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next 'sécurité
Range("A3:F" & Rows.Count).Delete xlUp 'RAZ
[N3] = "=(K3>7)*OR(M3=2,M3=3)" 'critère du filtre
With Intersect(Range("H2:M" & Rows.Count), UsedRange.EntireRow)
  .AdvancedFilter xlFilterInPlace, [N2:N3] 'filtre avancé
  .Copy [A2]
End With
[N3] = ""
ShowAllData
Application.EnableEvents = True
End Sub

La macro se déclenche quand on modifie/valide une cellule quelconque de la feuille.

Bonne journée.

 

[ChTi160]

Bonjour GUIDO
Bonjour le Fil(Oupps job75 ,Toujours dans la Course ! Lol) ,Le Forum
une approche Lol
Bonne Journée
Amicalement
jean marie
Ps : j'ai modifié quelques trucs Lol

 

[job75]

Re, salut ChTi160,

Plus simple :

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next 'sécurité
Range("A3:F" & Rows.Count).Delete xlUp 'RAZ
[N3] = "=(K3>7)*OR(M3=2,M3=3)" 'critère du filtre
Intersect(Range("H2:M" & Rows.Count), UsedRange).AdvancedFilter xlFilterCopy, [N2:N3], [A2:F2] 'filtre avancé
[N3] = ""
Application.EnableEvents = True
End Sub

A+

 

[job75]

Re,

On peut même ne pas s'occuper du UsedRange :

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next 'sécurité
Range("A3:F" & Rows.Count).Delete xlUp 'RAZ
[N3] = "=(K3>7)*OR(M3=2,M3=3)" 'critère du filtre
Range("H2:M" & Rows.Count).AdvancedFilter xlFilterCopy, [N2:N3], [A2:F2] 'filtre avancé
[N3] = ""
Application.EnableEvents = True
End Sub

A+

 

[Guido]

Re

Bonjour le fil
Bonjour Job75,Merci de participer a ma demande
Bonjour Jean marie

Merci pour vos propositions

Je vais essayé d'adapter sur mon fichier !!!

Et je Vous dit..

A Plus

Guido

 

[job75]

Bonjour Guido, ChTi160,

Comme il y aura toujours peu de lignes à traiter on peut comme ChTi160 les copier une par une :

Dans ce cas utiliser cette macro :

Private Sub Worksheet_Change(ByVal r As Range)
Dim lig&
lig = 3 '1ère ligne à renseigner
Application.EnableEvents = False
For Each r In Range("A1:M1", UsedRange).Rows
  If Val(CStr(r.Cells(11))) > 7 And (CStr(r.Cells(13)) = "2" Or CStr(r.Cells(13)) = "3") _
    Then r.Cells(8).Resize(, 6).Copy Cells(lig, 1): lig = lig + 1
Next
Range("A" & lig & ":F" & Rows.Count).Delete xlUp 'RAZ en dessous
Application.EnableEvents = True
End Sub

J'ai mis des CStr au cas où il y aurait des valeurs d'erreur...

Fichier (2).

C'est bien plus lent qu'au post #5 mais si une seule feuille est traitée ça n'a guère d'importance.

A+

 

[Guido]

Bonjour le Forum ,
Bonjour Job75

Merci pour cette nouvelle proposition

A plus ,je te dirais..

Guido

 

[job75]

Re,

J'ai mesuré les durées d'exécution des macros :

- post #5 => 3 centièmes de seconde mais parfois (?) 1,5 centième

- post #7 => 4,5 centièmes de seconde (avec Application.ScreenUpdating = False).

Finalement la différence n'est pas très grande, mais peu de lignes (9 sur 38) sont copiées.

Avec 38 lignes copiées on obtient respectivement 3 centièmes et 18 centièmes.

A+

 

[job75]

Re,

Classiquement la solution la plus rapide est celle qui utilise des tableaux VBA :

Private Sub Worksheet_Change(ByVal r As Range)
Dim source, rest(), i&, n&, j%
If FilterMode Then ShowAllData 'si la feuille est filtrée
source = Range("H3", Range("M" & Rows.Count).End(xlUp)(3)) 'matrice, plus rapide
ReDim rest(1 To UBound(source), 1 To 6)
For i = 1 To UBound(rest)
  If Val(CStr(source(i, 4))) > 7 And (CStr(source(i, 6)) = "2" Or CStr(source(i, 6)) = "3") Then
    n = n + 1
    For j = 1 To 6
      rest(n, j) = source(i, j)
    Next
  End If
Next
Application.EnableEvents = False
If n Then [A3].Resize(n, 6) = rest 'restitution
Range("A" & n + 3 & ":F" & Rows.Count) = "" 'RAZ en dessous
Application.EnableEvents = True
End Sub

Fichier (3).

Copie de 9 lignes => 1,5 centième, copie de 38 lignes => 2 centièmes de seconde.

A+

 

[Guido]

Bonsoir

Merci Job75 pour le dernier fichier

a bientôt

Guido