[XL-2007] Problème filtre automatique [Résolu]

[manu900]

Bonjour à tous,

Nouveau sur le forum j'ai terriblement besoin de votre aide pour résoudre un problème lié à la fonction autofilter pour la création d'un planning automatique pour les formations dans mon entreprise.
Je dois réaliser une macro qui :
-crée un autre onglet avec la date du jour
-prend en compte seulement les lignes avec des "x" suivant la date du jour.

Sur la page qui sera créer ne doit figurer seulement le nom, prénom et service des individus disposant d'une formation à la date du jour.

J'ai commancer à rédiger les lignes de codes : pour la première partie, j'ai réussi à créer un autre onglet avec comme nom la date du jour. Pour la seconde je n'y arrive pas.

J'ai utilisé la fonction Autofilter sans grande réussite car les dates de l'année figure dans une plage de colonne or cette fonction ne prend en compte qu'une seule colonne pour la réalisation d'un filtre : Comment faire si vous plait?

Pour mieux comprendre vous trouverez ci-joint mon fichier excel et ci-dessous les lignes de codes déja écrites:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub planning()
 
Sheets("PLANNING").Select
    NbFeuilles = Sheets.Count 'Compte le nombre de feuilles du fichier actif
    Sheets("PLANNING").Copy Before:=Sheets(NbFeuilles)
    Sheets("PLANNING (2)").Select
    ActiveSheet.Name = Format(Date, "dd-mm-yyyy")
    ActiveSheet.Unprotect
    Application.EnableEvents = False ' => désactive les événements
 
     If Err.Number = 1004 Then ' Renseigne l'utilisateur. Puis efface l'objet
    MsgBox "Erreur une feuille du même nom pour la même semaine existe déja"
End If
 
Selection.AutoFilter Field:=4:304, Criteria1:=Format(Date, "dd-mm-yyyy"), Criteria2:="x"

VBA Planning.xlsx

Merci encore pour vos réponses.

Bonne journée.

[mercatog]

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Sub Planning()
Dim Dte As String, Msg As String
Dim Plage As Range, c As Range
Dim Sh As Worksheet
Dim LastLig As Long
Dim Col As Integer
 
Application.ScreenUpdating = False
Dte = Format(Date, "dd-mm-yyyy")
If Existe(Dte) Then
    Set Sh = ThisWorkbook.Worksheets(Dte)
    Sh.UsedRange.Clear
End If
 
With Worksheets("PLANNING")
    .AutoFilterMode = False
    Set c = .Range("D3:BP3").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not c Is Nothing Then
        Col = c.Column
        Set c = Nothing
        LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Plage = .Range(.Cells(3, 1), .Cells(LastLig, Col))
        Plage.AutoFilter Field:=Col, Criteria1:="<>"
        If Plage.Columns(Col).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Dte = Format(Date, "dd-mm-yyyy")
            If Sh Is Nothing Then
                Set Sh = Worksheets.Add(After:=Sheets(Sheets.Count))
                Sh.Name = Dte
            End If
            .Range("A3:C" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
        Else
            Msg = "Aucune formation programmée aujourd'hui"
        End If
        Set Plage = Nothing
    Else
        Msg = "La date d'aujourd'hui inexistante sur la planning"
    End If
    .AutoFilterMode = False
End With
Set Sh = Nothing
If Msg = "" Then Msg = "Création feuille terminée"
MsgBox Msg
End Sub
 
Function Existe(ByVal ShName As String) As Boolean
Dim Sh As Worksheet
 
For Each Sh In ThisWorkbook.Sheets
    If Sh.Name = ShName Then
        Existe = True
        Exit For
    End If
Next Sh
End Function

[manu900]

Merci Énormément, cela fonctionne parfaitement.

Très bonne soirée et merci encore mercatog.

Bonjour Mercatoc,

Je reviens vers vous pour savoir si il était possible de rajouter des lignes et des colonnes dans les nouveaux onglets qui seront crées. Je souhaiterai effectuer cette opération afin d'améliorer la mise en page du planning de la journée.

Merci de votre réponse,

Bonne journée.

Cordialement

[mercatog]

Ajoute une procédure de mise en page avec comme paramètre la feuille de calcul qu'on appelle à partir de notre procédure principale.

Exemple

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Sub Planning()
Dim Dte As String, Msg As String
Dim Plage As Range, c As Range
Dim Sh As Worksheet
Dim LastLig As Long
Dim Col As Integer
 
Application.ScreenUpdating = False
Dte = Format(Date, "dd-mm-yyyy")
If Existe(Dte) Then
    Set Sh = ThisWorkbook.Worksheets(Dte)
    Sh.UsedRange.Clear
End If
 
With Worksheets("PLANNING")
    .AutoFilterMode = False
    Set c = .Range("D3:BP3").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not c Is Nothing Then
        Col = c.Column
        Set c = Nothing
        LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Plage = .Range(.Cells(3, 1), .Cells(LastLig, Col))
        Plage.AutoFilter Field:=Col, Criteria1:="<>"
        If Plage.Columns(Col).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Dte = Format(Date, "dd-mm-yyyy")
            If Sh Is Nothing Then
                Set Sh = Worksheets.Add(After:=Sheets(Sheets.Count))
                Sh.Name = Dte
            End If
            .Range("A3:C" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
            'Ici appel macro mise en page
            Call MiseEnPage(Sh)
        Else
            Msg = "Aucune formation programmée aujourd'hui"
        End If
        Set Plage = Nothing
    Else
        Msg = "La date d'aujourd'hui inexistante sur la planning"
    End If
    .AutoFilterMode = False
End With
Set Sh = Nothing
If Msg = "" Then Msg = "Création feuille terminée"
MsgBox Msg
End Sub
 
Private Function Existe(ByVal ShName As String) As Boolean
Dim Sh As Worksheet
 
For Each Sh In ThisWorkbook.Sheets
    If Sh.Name = ShName Then
        Existe = True
        Exit For
    End If
Next Sh
End Function
 
'Par exemple
Private Sub MiseEnPage(ByVal Ws As Worksheet)
 
With Ws
    .Rows(2).Insert
    .Range("D1:E1") = Array("Lieu", "Observations")
    With .Range("A1:E1")
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Interior.ColorIndex = 16
    End With
    .UsedRange.Borders.LineStyle = xlContinuous
End With
End Sub

[manu900]

Merci infiniment,

Sa marche impeccable.

Par hasard, serais-tu comment inserer une ligne au milieu d'un tableau car j'ai fait pas mal de recherche sur google et j'ai rien trouvé.

Merci pour tout

[mercatog]

Que veux tu dire avec insérer une ligne en milieu.
Que signifie milieu?

Pour insérer une ligne avant la ligne 10 de la feuille Feuil1, tu écris

Code :

Worksheets("Feuil1").Rows(10).Insert

Reste à savoir pour ton cas, le n° de la ligne correspondant à ton milieu décrit ton ton post.

[manu900]

Le tableau créer lors de ma macro sera long, ce que je souhaite c'est diviser ce tableau en deux (au milieu) en insérant une ligne pour répartir les formations le matin et les autres l'après midi.

[mercatog]

Je ne sais si j'ai bien compris mais essaies ceci

Code :

1
2
3
4
5
6
7
8
9
Private Sub MiseEnPage(ByVal Ws As Worksheet)
Dim LastLig As Long, Lig As Long
 
With Ws
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Lig = Int(LastLig / 2) + 1
    .Rows(Lig).Insert
End With
End Sub

[manu900]

Parfait, c'est exactement cela. Par contre comment fais tu pour fusionner les cellules de la ligne créer car elle peut ce situer n'importe ou, tu ne peux pas mettre Range("")


Merci pour tout.

[manu900]

Bonjour Mercatog

Aurais tu une réponse à la question d'hier car j'essaye depuis sans grande réussite,

J'ai essayé la fonction :

Code :

1
2
.Range("A:A").SpecialCells(xlCellTypeBlanks).Select
.MergeCells=true

Le résultat n'est pas très convaincant.

Merci encore pour ton aide.

[mercatog]

Code :

1
2
3
4
5
6
7
8
9
10
Private Sub MiseEnPage(ByVal Ws As Worksheet)
Dim LastLig As Long, Lig As Long
 
With Ws
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    Lig = Int(LastLig / 2) + 1
    .Rows(Lig).Insert
    .Range("A" & Lig & ":E" & Lig).Merge
End With
End Sub

[manu900]

Merci,

Je te sollicite une dernière si tu le veux bien,

J'aimerai juste rajouter des lignes de code pour interdire l'exécution de la macro si la feuille du jour à déja été crée avec un messbox.
Pour conclure l'utilisateur peut cliquer une seule fois sur la macro.Merci

Cordialement

[mercatog]

Il faudrait absolument que tu parvienne à comprendre le code, sinon tu ne t'en sortiras pas.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub Planning()
Dim Dte As String, Msg As String
Dim Plage As Range, c As Range
Dim Sh As Worksheet
Dim LastLig As Long
Dim Col As Integer
 
Application.ScreenUpdating = False
Dte = Format(Date, "dd-mm-yyyy")
If Not Existe(Dte) Then
    Set Sh = Worksheets.Add(After:=Sheets(Sheets.Count))
    Sh.Name = Dte
    With Worksheets("PLANNING")
        .AutoFilterMode = False
        Set c = .Range("D3:BP3").Find(Date, LookIn:=xlFormulas, lookat:=xlWhole)
        If Not c Is Nothing Then
            Col = c.Column
            Set c = Nothing
            LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
            Set Plage = .Range(.Cells(3, 1), .Cells(LastLig, Col))
            Plage.AutoFilter Field:=Col, Criteria1:="<>"
            If Plage.Columns(Col).SpecialCells(xlCellTypeVisible).Count > 1 Then
                Dte = Format(Date, "dd-mm-yyyy")
                .Range("A3:C" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A1")
                'Ici appel macro mise en page
                Call MiseEnPage(Sh)
            Else
                Msg = "Aucune formation programmée le " & Dte
            End If
            Set Plage = Nothing
        Else
            Msg = "La date d'aujourd'hui inexistante sur la planning"
        End If
        .AutoFilterMode = False
    End With
    Set Sh = Nothing
Else
    Msg = "Feuille du " & Dte & " a été déjà créée"
End If
If Msg = "" Then Msg = "Création de la feuille du " & Dte & " terminée"
MsgBox Msg
End Sub

[manu900]

Merci Mercatog

Bonne soirée