aide sur code vba et MFC

[nrdz83]

😎Bonjour à tous voila dans le classeur ci-joint je cherche à filtrer , faire apparaitre les gens présents le jour sélectionner via un userform. AInsi qu'une MFC malgrés une MFC déja utilisée. D'avance merci à tous mes amitiés

 

[PMO2]

Re : aide sur code vba et MFC

Bonjour,

Les MFC étant limitées, ce n'est pas la bonne méthode si vous en utilisez plus de 3.
Aussi ai-je éliminé toutes les MFC de ce classeur.
Il faut que de votre côté vous fassiez de même en éliminant toutes les MFC.

On va les remplacer par un code évènementiel qui autorise toutes les mises en forme conditionnelle.

1) Copiez le code suivant dans la fenêtre de code de ThisWorkbook

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Call MiseEnForme(Sh, Target)
End Sub

2) Copiez le code suivant dans un module standard

Sub MiseEnForme(Sh As Worksheet, Target As Range)
Dim Exclues
Dim LastLig&
Dim LastCol&
Dim R As Range
Dim Rdate As Range
Dim Rp As Range
Dim Rm As Range
Dim Rs As Range
Dim C As Range
Dim cpt&
On Error GoTo Erreur
Exclues = Array("Exposé", "titi", "toto") 'Feuilles exclues du traitement A adapter
For cpt& = LBound(Exclues) To UBound(Exclues)
  If Sh.Name = Exclues(cpt&) Then Exit Sub
Next cpt&
LastLig& = Sh.[a65536].End(xlUp).Row
LastCol& = Sh.[iv2].End(xlToLeft).Column
cpt& = 3
Set R = Application.Intersect(Target, Sh.Range(Sh.Cells(3, cpt&), Sh.Cells(LastLig&, LastCol&)))
If R Is Nothing Then Exit Sub
Set R = Nothing
Application.ScreenUpdating = False
Set R = Sh.Range(Sh.Cells(2, cpt&), Sh.Cells(LastLig&, LastCol&))
R.Interior.ColorIndex = xlNone
Set R = Nothing
Set Rdate = Sh.Range(Sh.Cells(2, cpt&), Sh.Cells(2, LastCol&))
Rdate.Interior.ColorIndex = 39
For Each C In Rdate
  If IsDate(C) Then
    If Weekday(C, vbMonday) > 5 Then
      If R Is Nothing Then
        Set R = Sh.Range(Sh.Cells(2, cpt&), Sh.Cells(LastLig, cpt&))
      Else
        Set R = Application.Union(R, Sh.Range(Sh.Cells(2, cpt&), Sh.Cells(LastLig&, cpt&)))
      End If
    End If
  End If
  cpt& = cpt& + 1
Next C
R.Interior.ColorIndex = 40
Set R = Nothing
cpt& = 3
Set R = Sh.Range(Sh.Cells(3, cpt&), Sh.Cells(LastLig&, LastCol&))
For Each C In R
  Select Case C
    Case "P"
      If Rp Is Nothing Then
        Set Rp = C
      Else
        Set Rp = Application.Union(Rp, C)
      End If
    Case "M"
      If Rm Is Nothing Then
        Set Rm = C
      Else
        Set Rm = Application.Union(Rm, C)
      End If
    Case "S"
      If Rs Is Nothing Then
        Set Rs = C
      Else
        Set Rs = Application.Union(Rs, C)
      End If
  End Select
  cpt& = cpt& + 1
Next C
If Not Rp Is Nothing Then Rp.Interior.ColorIndex = 37
If Not Rm Is Nothing Then Rm.Interior.ColorIndex = 38
If Not Rs Is Nothing Then Rs.Interior.ColorIndex = 44
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur " & Err.Number & vbCrLf & _
    Err.Description
End Sub

3) Copiez le code suivant dans la fenêtre de code de UserForm1

Dim DP As DTPicker
Dim S As Worksheet
Dim LastLig&
Dim LastCol&

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub CommandButton2_Click()
Dim Col&
Dim R As Range
Dim C As Range
Dim i&
On Error GoTo Erreur
Application.ScreenUpdating = False
Call Visibilite
Col& = DP.Day + 2
Set R = S.Range(S.Cells(3, Col&), S.Cells(LastLig&, Col&))
For Each C In R
  If C <> "" Then S.Rows(C.Row).EntireRow.Hidden = True
Next C
For i& = 3 To LastCol&
  If i& <> Col& Then S.Columns(i&).EntireColumn.Hidden = True
Next i&
Erreur:
Application.ScreenUpdating = True
Me.Hide
End Sub

Private Sub CommandButton3_Click()
Call Visibilite
End Sub

Private Sub UserForm_Initialize()
Set DP = Me.DTPicker1
Set S = ActiveSheet
Call Visibilite
LastLig& = S.[a65536].End(xlUp).Row
LastCol& = S.[iv2].End(xlToLeft).Column
DP.Month = Month(S.[c2])
DP.Day = 1
End Sub

Private Sub Visibilite()
With S.Cells
  .EntireRow.Hidden = False
  .EntireColumn.Hidden = False
End With
End Sub

4) Ajoutez à UserForm1 un contrôle Bouton de commande avec
propriété (Name) CommandButton3
propriété Caption Afficher tout

Il n'y a plus qu'à faire les tests.
Vive la marine nationale.

Cordialement.

PMO
Patrick Morange