Exporter Feuille visible avec onglet couleur BLEU

Le 07/03/2013 à 13:17

Bonjour à tous,

J'ai actuellement un code VBA me permettant d'exporter dans un nouveau classeur xls certaines feuilles.

Je souhaite rajouter la possibilité de pouvoir exporter toutes les Feuilles Visibles dont la couleur d'onglet est BLEU (la couleur BLEU est un exemple), pouvez vous m'aider ? voici le code initial

Sub enregistrer_sous()

On Error GoTo FinEnregistrer

Application.EnableEvents = False

' On vérifie qu'une case au moins est cochée

If Range("sommefeuilles") > 0 Then

CeClasseur = ActiveWorkbook.Name

NomNouvClasseur = Range("titreclasseur")

Set NouvClasseur = Workbooks.Add

NouvClasseur.SaveAs Filename:=ThisWorkbook.Path & "\" & NomNouvClasseur

Workbooks(CeClasseur).Activate

If Feuil27.Range("lot_four") = True Then _

Feuil15.Copy after:=Workbooks(2).Sheets(Workbooks(2).Sheets.Count)

If Feuil27.Range("lot_cuisson") = True Then _

Feuil2.Copy after:=Workbooks(2).Sheets(Workbooks(2).Sheets.Count)

If couleur d'onglet = BLEU alors

copier toutes les feuilles du classeur

Else

MsgBox "Vous n'avez coché aucune feuille"

End If

Application.DisplayAlerts = False

For n = 1 To 3

Sheets("Feuil" & n).Delete

Next

Application.DisplayAlerts = True

FinEnregistrer:

Application.EnableEvents = True

End Sub

Le 07/03/2013 à 18:45

précision,

je souhaite uniquement copier les feuilles visible dont la couleur de l'onglet est BLEU.

Le 07/03/2013 à 18:55

Salut Babouze,

J’ai enregistré une macro avec l’enregistreur afin de voir quel code était généré si on colorie l’onglet avec une « Couleur du thème ». Ca a donné la macro 1. Puis j’ai essayé avec une « Couleur standard » et ça a donné la macro 2.

Ensuite j’ai repris le code de la macro 2 afin de créé le code « aa » et ça marche.

Est-ce que ça te permets d’avancer ??

Sub Macro1()

    Sheets("Feuil1").Select
    With ActiveWorkbook.Sheets("Feuil1").Tab
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
    End With
    Range("D36").Select
End Sub
Sub Macro2()

    Sheets("Feuil2").Select
    With ActiveWorkbook.Sheets("Feuil2").Tab
        .Color = 15773696
        .TintAndShade = 0
    End With
End Sub
 Sub aa()
 Dim i As Integer

 For i = 1 To Sheets.Count
    If Sheets(i).Tab.Color = 15773696 And Sheets(i).Visible = True Then MsgBox (Sheets(i).Name)
 Next
 End Sub

NB : Je ne peux pas savoir quel bleu tu as choisi

Cordialement.

22babouze.xlsm (20.37 Ko)
Le 07/03/2013 à 22:43

en fait, quand je l'integre dans mon code complet (voir ci dessous) ça ne marche pas completement,

en fait mon code doit faire 2 copie :

  • une copie en fonction de la valeur VRAI d'une cellule relié à une Feuille précise (code vert)
  • une copie multiple en fonction de la couleur + visibilité de plusieurs feuilles (code rouge)

selon que je place le code vert ou rouge en premier, seul le premier code s'effectue mais pas l'autre, ma copie est incomplète,

De plus lors de mes essai, il y avait un message d'erreur "erreur de compilation Next sans For" ???

Pouvez vous m'aider ?

Sub enregistrer_sous()

Dim i As Integer

On Error GoTo FinEnregistrer

Application.EnableEvents = False

' On vérifie qu'une case au moins est cochée

If Range("sommefeuilles") > 0 Then

CeClasseur = ActiveWorkbook.Name

NomNouvClasseur = Range("titreclasseur")

Set NouvClasseur = Workbooks.Add

NouvClasseur.SaveAs Filename:=ThisWorkbook.Path & "\" & NomNouvClasseur

Workbooks(CeClasseur).Activate

If Feuil27.Range("compte_rendu") = True Then _

Feuil19.Copy after:=Workbooks(2).Sheets(Workbooks(2).Sheets.Count)

If Feuil27.Range("reception_materiel") = True Then _

Feuil30.Copy after:=Workbooks(2).Sheets(Workbooks(2).Sheets.Count)

If Feuil27.Range("lot_rénovation") = True Then _

Feuil48.Copy after:=Workbooks(2).Sheets(Workbooks(2).Sheets.Count)

For i = 1 To Sheets.Count

If Sheets(i).Tab.Color = 10498160 And Sheets(i).Visible = True Then Sheets(i).Copy after:=Workbooks(2).Sheets(Workbooks(2).Sheets.Count)

Next

Else

MsgBox "Vous n'avez coché aucune feuille"

End If

Application.DisplayAlerts = False

For n = 1 To 3

Sheets("Feuil" & n).Delete

Next

Application.DisplayAlerts = True

FinEnregistrer:

Application.EnableEvents = True

End Sub

Le 08/03/2013 à 07:26

Salut,

Tout d'abord - afin de respecter la charte du Forum - voici une petite réserve de "bonjour" et de "merci pour ton aide" :

bonjour, bonjour, bonjour, bonjour, bonjour, bonjour, bonjour, bonjour, bonjour, bonjour

merci pour ton aide, merci pour ton aide, merci pour ton aide, merci pour ton aide, merci pour ton aide, merci pour ton aide, merci pour ton aide.

Sans avoir ton fichier à disposition, il est difficile de t'aider mieux. Je veux bien créer un fichier qui peut ressembler au tien - comme je l'ai fait pour ma première réponse - mais le travail qui m'incombe en plus pour le réaliser plus les risques qu'il ne ressemble pas exactement au tien me découragent.

Alors merci d'avance de placer ton fichier sur le fil.

Cordialement.

Le 08/03/2013 à 11:34

ok,

j'ai mis le fichier en PJ,

il comporte 6 Feuilles

1 Feuille enregistrer qui permet de choisir les Feuilles à exporter (1 seule dans l'exemple)

1 Feuille TELECOPIE reunion de chantier qui est une Feuille à exporter via case à cocher

1 Feuille 777 visible avec la mauvaise couleur d'onglet

1 Feuille 778 visible avec la bonne couleur d'onglet

1 Feuille 779 masqué avec la bonne couleur d'onglet

1 Feuille 780 masqué avec la mauvaise couleur d'onglet

Le but est de copier les feuilles dont la case à cocher est active + les onglets des feuilles visibles dont la couleur correspond.

Lors de mes essais, constatation :

lorsque le code couleur est en dessous du code case à cocher, seulement la case à cocher est copié

lorsque le code couleur est dessus du code case à cocher, seulement la Feuille 778 (meme si 779 visible) est copié, mais manque case à cocher + suppression des FEUIL 1,2,3 du classeur cible

Bref, j'ai l'impression que la boucle ne s'effectue pas ...

J'espere t'avoir fourni suffisament d'elements.

Cordialement.

12babouze.zip (50.76 Ko)
Le 08/03/2013 à 16:43

Si toutefois vous avez un autre code VBA qui fonctionne, je ne suis pas attaché à celui là.

Le 08/03/2013 à 18:53

Bonjour

Un essai

A voir dans le code la modification pour Excel 2003

16babouze64-exporter-v001.zip (55.02 Ko)
Le 08/03/2013 à 20:14

je teste ...

effectivement, j'ai du remettre mon code couleur d'origine pour que cela fonctionne,

Y a t'il des codes couleurs "communs" entre xls 2003 et 2007 voire 2010 ?

Je crois que je vais etre obligé de trouver un commun pour que cela fonctionne quel que soit la version d'excel !

Le 08/03/2013 à 22:33

j'ai modifié ton code pour pouvoir "cocher plusieurs" Feuilles, mais j'ai dut mal m'y prendre car seulement une Feuille sur les "x" apparait.

Serait-ce à cause d'un ecrasement d'une feuille sur l'autre ou autre chose ?

deuxième question, si dans le même style, je souhaite cocher une case pour déclencher la partie copy onglet coloré, comment dois-je mis prendre ? en sachant que le code serait de la forme : If Feuil27.Range("descriptifs") = True Then "déclencher copy onglet visible coloré"

Sub enregistrer_sous()

Dim LesFeuilles()

Dim I As Integer, Indice As Integer

Dim NomNouvClasseur As String

On Error GoTo FinEnregistrer

Application.EnableEvents = False

' On vérifie qu'une case au moins est cochée

If Range("sommefeuilles") > 0 Then

Application.ScreenUpdating = False

ReDim Preserve LesFeuilles(Indice)

If Feuil27.Range("reunion_chantier") = True Then

LesFeuilles(Indice) = Feuil20.Name

End If

If Feuil27.Range("presentation_cctp") = True Then

LesFeuilles(Indice) = Feuil8.Name

End If

If Feuil27.Range("recap_matos") = True Then

LesFeuilles(Indice) = Feuil26.Name

End If

If Feuil27.Range("convocation_ris") = True Then

LesFeuilles(Indice) = Feuil17.Name

End If

If Feuil27.Range("reservation") = True Then

LesFeuilles(Indice) = Feuil1.Name

End If

If Feuil27.Range("transmis") = True Then

LesFeuilles(Indice) = Feuil12.Name

End If

If Feuil27.Range("compte_rendu") = True Then

LesFeuilles(Indice) = Feuil19.Name

End If

If Feuil27.Range("reception_materiel") = True Then

LesFeuilles(Indice) = Feuil30.Name

End If

For I = 1 To Sheets.Count

If Sheets(I).Tab.Color = 10498160 And Sheets(I).Visible = True Then

Indice = Indice + 1

ReDim Preserve LesFeuilles(Indice)

LesFeuilles(Indice) = Sheets(I).Name

End If

Next I

NomNouvClasseur = Range("titreclasseur")

Application.DisplayAlerts = False ' Evite message sur les liens

Sheets(LesFeuilles()).Copy

Application.DisplayAlerts = True ' Remet en service les messages

With ActiveWorkbook

.SaveAs Filename:=ThisWorkbook.Path & "\" & NomNouvClasseur

.Close

End With

Else

MsgBox "Vous n'avez coché aucune feuille"

End If

MsgBox "terminé"

FinEnregistrer:

Application.EnableEvents = True

End Sub

Le 08/03/2013 à 23:05

Bonsoir

babouze64 a écrit :

Serait-ce à cause d'un ecrasement d'une feuille sur l'autre

Oui si l'indice n'est pas modifié

Sans ton fichier réel (structure) pas évident de simplifier le code (pas sur que l'on y arrive)

Quand tu places du code utilises les balises Code (au dessus à droite de la fenêtre d'édition), la lecture de celui-ci en sera facilitée

Pour la 2ème question tu prépares un fichier dans lequel tu expliques ce que tu veux faire

Option Explicit

Sub enregistrer_sous()
Dim LesFeuilles()
Dim I As Integer, Indice As Integer
Dim NomNouvClasseur As String

  On Error GoTo FinEnregistrer
  Application.EnableEvents = False
  ' On vérifie qu'une case au moins est cochée
  If Range("sommefeuilles") > 0 Then
    Application.ScreenUpdating = False
    If Feuil27.Range("reunion_chantier") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil20.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("presentation_cctp") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil8.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("recap_matos") = True Then
      LesFeuilles(Indice) = Feuil26.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("convocation_ris") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil17.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("reservation") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil1.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("transmis") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil12.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("compte_rendu") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil19.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("reception_materiel") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil30.Name
      Indice = Indice + 1
    End If

    For I = 1 To Sheets.Count
      If Sheets(I).Tab.Color = 10498160 And Sheets(I).Visible = True Then
        ReDim Preserve LesFeuilles(Indice)
        LesFeuilles(Indice) = Sheets(I).Name
        Indice = Indice + 1
      End If
    Next I

    NomNouvClasseur = Range("titreclasseur")
    Application.DisplayAlerts = False ' Evite message sur les liens
    Sheets(LesFeuilles()).Copy
    Application.DisplayAlerts = True ' Remet en service les messages
    With ActiveWorkbook
      .SaveAs Filename:=ThisWorkbook.Path & "\" & NomNouvClasseur
      .Close
    End With
  Else
    MsgBox "Vous n'avez coché aucune feuille"
  End If
  MsgBox "terminé"
FinEnregistrer:
  Application.EnableEvents = True
End Sub
Le 09/03/2013 à 01:02

Merci encore pour ton boulot, rapide et efficace.

Ton code fonctionne à merveille et pour la simplification, pas besoin, ça fonctionne, ça ne ralenti pas, c'est génial.

Pour mon souhait N°2, ça fonctionne, le code est repéré entre commentaires ci-dessous, j'ai réussi à m'en sortir seul (pour une fois !!)

A+

Sub enregistrer_sous()
Dim LesFeuilles()
Dim I As Integer, Indice As Integer
Dim NomNouvClasseur As String

  On Error GoTo FinEnregistrer
  Application.EnableEvents = False
  If Range("sommefeuilles") > 0 Then
    Application.ScreenUpdating = False

    If Feuil27.Range("reunion_chantier") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil20.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("presentation_cctp") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil8.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("recapitulatif") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil26.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("convocation_ris") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil17.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("reservation") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil1.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("transmis") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil12.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("compte_rendu") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil19.Name
      Indice = Indice + 1
    End If
    If Feuil27.Range("reception_materiel") = True Then
      ReDim Preserve LesFeuilles(Indice)
      LesFeuilles(Indice) = Feuil30.Name
      Indice = Indice + 1
    End If

'code du souhait N°2

    If Feuil27.Range("descriptifs") = True Then
        For I = 1 To Sheets.Count
            If Sheets(I).Tab.Color = 10498160 And Sheets(I).Visible = True Then
                ReDim Preserve LesFeuilles(Indice)
                LesFeuilles(Indice) = Sheets(I).Name
                Indice = Indice + 1
            End If
        Next I
    End If

'fin code souhait N°2 

    NomNouvClasseur = Range("titreclasseur")
    Application.DisplayAlerts = False ' Evite message sur les liens
    Sheets(LesFeuilles()).Copy
    Application.DisplayAlerts = True ' Remet en service les messages
    With ActiveWorkbook
      .SaveAs Filename:=ThisWorkbook.Path & "\" & NomNouvClasseur
      .Close
    End With
  Else
    MsgBox "Vous n'avez coché aucune feuille"
  End If
  MsgBox "terminé"
FinEnregistrer:
  Application.EnableEvents = True
End Sub
Le 09/03/2013 à 01:07

Bonjour

A voir

balise code v002

Par exemple tu édites ton message précédent, tu sélectionnes tout ton code et tu cliques sur la balise code (entouré de rouge)

Le 09/03/2013 à 01:11

je m'en suis rendu compte en éditant mon message précedent.

A+

Le 09/03/2013 à 14:18

BonjourR à tous.

Ma question n'est pas en rapport direct avec le post d'origine.

J'ai copié la macro 2 de " Yvouille" qui m'intéresse.

Sub Macro2() ' Change_couleur_2_L_onglet

Sheets("Feuil2").Select

With ActiveWorkbook.Sheets("Feuil2").Tab

.Color = 15773696

.TintAndShade = 0

End With

End Sub

Ma question est la suivante :

est-il possible que lorsque l'on rajoute un onglet, le nouvel onglet change de couleur, pour ne jamais avoir 2 onglet de même couleur qui se suivent.

B.Ap.M à tous Roland

Rechercher des sujets similaires à "exporter feuille visible onglet couleur bleu"