Appliquer à des Onglets définis

[Squoltahthx94]

Bonjour,

Je souhaite appliquer un traitement à chaque onglet 'sxxxx' de mon classeur via un bouton mais cela n'a pas l'ai de fonctionner...Pourrais t'on m'aider??

Private Sub CommandButton4_Click()
Dim Ws As Worksheet
Dim derlig&, plage As Range, i&, t, d As Object
  For Each Ws In Sheets(Array("S0101", "S0201", "S0301", "S0401", "S0501"))
    If Not ActiveSheet.Name Like "S####" Then Exit Sub
derlig = [B3].End(xlDown).Row
If derlig = Rows.Count Then Exit Sub
Application.ScreenUpdating = False
Set plage = Range("A3:I" & derlig)
'---tableau préparatoire trié---
Range("A" & derlig + 1 & ":I" & Rows.Count).Delete xlUp 'RAZ
plage.Copy Cells(derlig + 1, 1)
Set plage = plage.Offset(plage.Rows.Count)
For i = 2 To plage.Rows.Count 'pour la 2ème clé de tri
  t = Trim(plage.Cells(i, 8))
  If t = "rouge" Then plage.Cells(i, 9) = 1
  If t = "orange" Then plage.Cells(i, 9) = 2
  If t = "jaune" Then plage.Cells(i, 9) = 3
  If t = "" Then plage.Cells(i, 9) = 4
Next
plage.Sort [B1], xlAscending, [I1], , xlAscending, [G1], xlAscending, xlYes
plage.Columns(9).ClearContents
'---liste des titres des tableaux---
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To plage.Rows.Count
  d(plage.Cells(i, 2).Value) = plage.Cells(i, 2).Value
Next
'---création des tableaux---
ActiveSheet.AutoFilterMode = False
For Each t In d.keys
  derlig = Cells(Rows.Count, 2).End(xlUp).Row
  Cells(derlig + 3, 2) = t
  Cells(derlig + 3, 2).Borders.LineStyle = 1 'bordures
  plage.AutoFilter 2, t 'filtre automatique
  plage.SpecialCells(xlCellTypeVisible).Copy Cells(derlig + 5, 1)
  plage.AutoFilter
Next
ActiveSheet.AutoFilterMode = False
plage.Delete xlUp
  Next Ws
End Sub

 

[ROGER2327]

Re : Appliquer à des Onglets définis

Bonjour Squoltahthx94

Une proposition non testée faute d'avoir le support :​

Private Sub CommandButton4_Click()
Dim Ws As Worksheet
Dim derlig&, plage As Range, i&, t, d As Object
Dim k&, fl()
    fl = Array("S0101", "S0201", "S0301", "S0401", "S0501") 'Liste des onglets à traiter.
    For k = 0 To UBound(fl)
        On Error GoTo E 'Pour le cas où l'onglet n'existe pas...
        Worksheets(fl(k)).Activate
        On Error GoTo 0
        derlig = [B3].End(xlDown).Row
        If derlig <> Rows.Count Then
            Application.ScreenUpdating = False
            Set plage = Range("A3:I" & derlig)
'---tableau préparatoire trié---
            Range("A" & derlig + 1 & ":I" & Rows.Count).Delete xlUp 'RAZ
            plage.Copy Cells(derlig + 1, 1)
            Set plage = plage.Offset(plage.Rows.Count)
            For i = 2 To plage.Rows.Count 'pour la 2ème clé de tri
                t = Trim(plage.Cells(i, 8))
                If t = "rouge" Then plage.Cells(i, 9) = 1
                If t = "orange" Then plage.Cells(i, 9) = 2
                If t = "jaune" Then plage.Cells(i, 9) = 3
                If t = "" Then plage.Cells(i, 9) = 4
            Next
            plage.Sort [B1], xlAscending, [I1], , xlAscending, [G1], xlAscending, xlYes
            plage.Columns(9).ClearContents
'---liste des titres des tableaux---
            Set d = CreateObject("Scripting.Dictionary")
            For i = 2 To plage.Rows.Count
                d(plage.Cells(i, 2).Value) = plage.Cells(i, 2).Value
            Next
'---création des tableaux---
            ActiveSheet.AutoFilterMode = False
            For Each t In d.keys
                derlig = Cells(Rows.Count, 2).End(xlUp).Row
                Cells(derlig + 3, 2) = t
                Cells(derlig + 3, 2).Borders.LineStyle = 1 'bordures
                plage.AutoFilter 2, t 'filtre automatique
                plage.SpecialCells(xlCellTypeVisible).Copy Cells(derlig + 5, 1)
                plage.AutoFilter
            Next
            ActiveSheet.AutoFilterMode = False
            plage.Delete xlUp
        End If
S:  Next k
Exit Sub
E: Resume S
End Sub

Comme cela n'est pas testé, prudence ! Faites des essais sur une copie de votre classeur de travail !​

Bonne journée.


ROGER2327
#6049

Samedi 21 Gidouille 139 (Saint Spéculum, confesseur - fête Suprême Quarte)
17 Messidor An CCXX, 4,2371h - groseille
2012-W27-4T10:10:08Z

 

[Squoltahthx94]

Re : Appliquer à des Onglets définis

oups c'est vrai je l'ai oublié le voici si besoin mais merci quand même je vais testé de mon côté

 

[Squoltahthx94]

Re : Appliquer à des Onglets définis

Non la mise en page ne se fait pas!!

 

[ROGER2327]

Re : Appliquer à des Onglets définis

Re...

Non la mise en page ne se fait pas!!

Ben oui ! Pour avoir la moindre chance que le code proposé s'exécute, il faut au minimum le copier dans le classeur...

Ceci dit, l'eussiez-vous fait que... ...la mise en page ne se serait pas faite. Au vu de votre classeur, j'apporte les modifications suivantes à ma proposition :

Dans le module de l'onglet Menu, le code doit être​

Private Sub CommandButton4_Click()
    toto
End Sub

Dans le module Module1 (ou tout autre module standard), mettre le code proposé au message #2 en remplaçant Private Sub CommandButton4_Click() par Sub toto.

Ceci fait, votre code s'exécutera. (Au moins, je l'espère.)
Fera-t-il ce que vous en attendez ? C'est une autre histoire...​

ROGER2327
#6050

Samedi 21 Gidouille 139 (Saint Spéculum, confesseur - fête Suprême Quarte)
17 Messidor An CCXX, 5,2210h - groseille
2012-W27-4T12:31:50Z

 

[Squoltahthx94]

Re : Appliquer à des Onglets définis

merci de votre retour; effectivement je n'avais que fournis le classeur. Merci encore

 

[ROGER2327]

Re : Appliquer à des Onglets définis

Re...

merci de votre retour; effectivement je n'avais que fournis le classeur. Merci encore

Pas grave, mais, finalement, est-ce que ça fonctionne ?
​

ROGER2327
#6051

Samedi 21 Gidouille 139 (Saint Spéculum, confesseur - fête Suprême Quarte)
17 Messidor An CCXX, 7,1111h - groseille
2012-W27-4T17:04:00Z

 

[Squoltahthx94]

Re : Appliquer à des Onglets définis

oui merci encore