Excel 2003 - Macro - Liste automatique - recherche suivant format couleur -Résolu

Question

bonjour à toutes et à tous!

J'aimerais vos lumières pour un petit fichier que j'ai amélioré aujourd'hui mais j'ai quelques petit souci, pas de problèmes majeurs (je l'espère en tout cas).
Sur le fichier joint - CDE CAMION 2011
J'ai en fait 3 principales macros.

[*] Le premier bouton sur l'onglet "Extraction" va en fait prendre les données des onglets "agent" qui sont les onglet avec 2 lettres, et les regrouper sur la page "Macro" évidemment comme vous avez pu le constater dès qu'il y a un espace, il passe à l'onglet suivant. Sachant que l'espace me sers en fait de séparateur entre chaque jour, je n'ai pas encore réussi à faire une liste complète. un peu d'aide m'enlèvera une épine du pied :)

[*] Sur le deuxième bouton qui est un des plus important , il me permet d'affecter un numéro ( qui correspond en fait au numéro maximum du classeur + 1 ) si l'agent a mis un 'x' sous "numéro de camion". Cependant il est INCROYABLEMENT long puisque le fichier sera par la suite partagé! 
Je me demandais si une âme généreuse aurait une idée pour réduire le temps de chargement. sans partage il prends 1-2 secondes et en partage il mets bien 30 à 90 voire 180 secondes.. je pense que le partage y est pour beaucoup mais j'espérais un peu plus rapide étant donné que mon code est assez simplissime et que je pense pouvoir faire mieux aux niveau de la passation de paramètres... (j'avais pensé à mettre une liste des onglets à prendre, mais je me suis pas encore vraiment penché à fond dessus)

[*] Enfin, le 3e bouton me permet en fait de garder un 'historique' de mes commandes. J'aimerais donc qu'en appuyant sur 'supprimer' les lignes en gris clair (couleur excel 2003) s'effacent (dans les tableaux des agents) et viennent se mettre dans la feuille "Synthèse", sans effacer les 'commandes' précédentes. Je suis en ce moment même en train de me brûler des neurones là dessus. Étant donnée que la macro enregistrée pour la recherche d'une case suivant son format de couleur n'est pas vraiment fonctionnelle lorsque l'on essaye de la ré-appliquée en vba... un peu d'aide serait la bienvenue également.

Je vous laisse donc jeter un œil à mon 'oeuvre'. Je suis désolée si un sujet similaire a été déjà posé, merci en tout cas de m'envoyer le lien.

Merci d'avance, 
Jennifer

bigfish_le vrai · Accepted Answer

Bonjour,

Ce qui donne:

Sub LISTE_ONGLETS
    Dim Feuile As Worksheet, derniereligne As Long, Maplage As Range
    Dim LigneDestinationSurFeuilMacro As Long

    With Sheets("MACRO").Cells
        .ClearContents
        .Borders.LineStyle = xlNone
        .Interior.ColorIndex = xlAutomatic
    End With
    
    LigneDestinationSurFeuilMacro = 1
    For Each feuille In ThisWorkbook.Worksheets
        With feuille
            'le if sert à trouver les feuilles 
            'à prendre en compte. Pour cela je me suit basé
            'sur la Cellule A2 qui contient la chaine "Légende"
            'Attention si tu déplaces ce texte ou le remplace cela ne fonctionnera plus
            If .Range("A2").Value = "Légende" Then
                derniereligne = .Range("A" & .Columns("A").Rows.Count).End(xlUp).Row
                Set Maplage = .Range("A6:J" & derniereligne)
                Maplage.AutoFilter Field:=1, Criteria1:="<>"
                Maplage.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Macro").Range("A" & LigneDestinationSurFeuilMacro)
                LigneDestinationSurFeuilMacro = Worksheets("Macro").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row + 1
                Maplage.AutoFilter
            End If
        End With
    Next
End Sub

Note que la méthode utilisée supprime les ligne rouge !

A+

ucfoutu · Answer

Bonjour,

 Crois-tu vraiment "dur comme fer" que nombreux seront les inconscients qui :
- ouvriront le lien
- téléchargeront ton fichier
- l'ouvriront (avec les risques que  cela peut comporter en matière de sécurité) ???

Pas moi !
Alors :
1) isole ton problème spécifique et isolé
2) mets ici (entre balises CODE) le code qui pose problème
Merci de faire ainsi .



____________________
Utiliser le bouton "REPONSE ACCEPTEE" sur une réponse exacte facilite les recherches ultérieures d'autres forumeurs. PENSEZ-Y SVP

givemecookies · Answer

ucfoutu,
J'y avais pas pensé, désolée..
Je poste ça dans quelques minutes ! ( j'éditerai)

Merci,
Jennifer

givemecookies · Answer

re-bonjour à tous,

(bon à croire que j'ai pas les yeux en face des trous, j'ai pas trouvé comment éditer..)

Commençons donc par mon premier problème.
Le premier bouton sur l'onglet "Extraction" va en fait prendre les données des onglets "agent" qui sont les onglet avec 2 lettres, et les regrouper sur la page "Macro" évidemment comme vous avez pu le constater dès qu'il y a un espace, il passe à l'onglet suivant. Sachant que l'espace me sers en fait de séparateur entre chaque jour, je n'ai pas encore réussi à faire une liste complète. un peu d'aide m'enlèvera une épine du pied :) 


voici à quoi ressemble mon onglet "Extraction" : 

Lorsque je clique sur le bouton 'lancer la macro' j'obtiens une liste comme celle là dans l'onglet "MACRO": 



qui provient en fait de 9 onglets agents de ce type :



Sub LISTE_ONGLETS()
    'nom des feuilles :
    F_1 = "CF"
    F_2 = "NB"
    F_3 = "JM"
    F_4 = "Mel"
    F_5 = "MA"
    F_6 = "PL"
    F_7 = "VR"
    F_8 = "SM"
    F_9 = "MG"
    
     'supprimer les données de la feuille 'MACRO'
    Sheets("MACRO").Select
    Cells.Select
    Selection.ClearContents ' j'aurais pu faire que clearcontent mais vu que j'ai besoin des couleurs dans la liste il me faut tout bien effacer.
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A1").Select
        
    'chercher dans CF - /!\ je pense que c'est à partir de là qu'il y a moyen de faire mieux je pense..
    Sheets(F_1).Select
    Range("A6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    
    Sheets("MACRO").Select
    ActiveSheet.Paste
    
    'chercher dans NB
    Sheets(F_2).Select
    Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans JM
    Sheets(F_3).Select
    Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans Mel
    Sheets(F_4).Select
    Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans MA
    Sheets(F_5).Select
    Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans PL
    Sheets(F_6).Select
    Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans VR
    Sheets(F_7).Select
    Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans SM
    Sheets(F_8).Select
   Call chercher 'permet de trouver la premiere case vide et de coller
    
    'chercher dans MG
    Sheets(F_9).Select
    Call chercher 'permet de trouver la premiere case vide et de coller


End Sub

Private Sub chercher()
    Range("A6").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    
    Sheets("MACRO").Select 'recherche la première ligne vide
    With Range("A:A")
    Set vide = .Find("")
    End With
    vide.Select
    ActiveSheet.Paste ' et colle les données
End Sub

Voilà j'ai un peu honte parce que c'est vraiment mal organisé. Mais je suis pas arrivée à faire dire à la macro que dans tous les onglets agent, il faut prendre la totalité du tableau sans l'en tête de colonne.
C'est pour cela que j'ai entrepris de faire une liste sur la page "Extraction" comme vous pouvez le voir dans la première image. J'avais pensé que peut être je peux mettre à jour le nom de la liste "liste_agent" par exemple et en suite faire une boucle do ou each pour dire que pour chaque onglet de la liste faire la macro.. Je sais pas ce que vous en pensez...

Désolée encore pour l'edit ratée.

Merci encore,
N'hésitez pas à demander plus d'informations
Jennifer

bigfish_le vrai · Answer

Salut,

oh  mon dieu ... que de sélections 

bon un peu de simplification pour commencer:

Je vais le faire en plusieurs étapes... pour la liste des feuilles il y a surement quelque chose à faire mais on verra cela plus tard

ceci : 

Sub LISTE_ONGLETS()
    'nom des feuilles :
    F_1 = "CF"
    F_2 = "NB"
    F_3 = "JM"
    F_4 = "Mel"
    F_5 = "MA"
    F_6 = "PL"
    F_7 = "VR"
    F_8 = "SM"
    F_9 = "MG"
    
     'supprimer les données de la feuille 'MACRO'
    Sheets("MACRO").Select
    Cells.Select
    Selection.ClearContents ' j'aurais pu faire que clearcontent mais vu que j'ai besoin des couleurs dans la liste il me faut tout bien effacer.
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A1").Select

peut être avantageusement remplacé par :

Sub LISTE_ONGLETS()
    'nom des feuilles :
    F_1 = "CF"
    F_2 = "NB"
    F_3 = "JM"
    F_4 = "Mel"
    F_5 = "MA"
    F_6 = "PL"
    F_7 = "VR"
    F_8 = "SM"
    F_9 = "MG"
    
     'supprimer les données de la feuille 'MACRO'
    With Sheets("MACRO").Cells
        .ClearContents
        .Borders.LineStyle = xlNone
    end With

Voila pour la première étape...

givemecookies · Answer

bigfish,

Effectivement..
Je suis toujours sur mon fichier pour essayer d'utiliser cette liste d'onglet au mieux 

j'avais pensé à utilisé quelquechose de ce genre :
Sub MAJ_nom()


    ActiveWorkbook.Names("onglets_agent").Delete
    Range("I3").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Names.Add Name:="onglets_agents", RefersToR1C1:= _
        Selection

    
    For Each rw In Range("onglets_agents")
         'mettre à ce moment la macro une seule fois ici..
    Next

End Sub


Merci en tout cas!
Jennifer

bigfish_le vrai · Answer

re,

uen petite precision à propos de:

Note que la méthode utilisée supprime les lignes rouge ! 

Parce qu'elles sont vide !

A+

givemecookies · Answer

bigfish,

wahoo, c'est tellement rapide que je pensais que la macro ne s'activait jamais! Merci beaucoup! c'est vraiment génial !

voici mon 2e problème:Sur le deuxième bouton qui est un des plus important , il me permet d'affecter un numéro ( qui correspond en fait au numéro maximum du classeur + 1 ) si l'agent a mis un 'x' sous "numéro de camion". Cependant il est INCROYABLEMENT long puisque le fichier sera par la suite partagé!
Je me demandais si une âme généreuse aurait une idée pour réduire le temps de chargement. sans partage il prends 1-2 secondes et en partage il mets bien 30 à 90 voire 180 secondes.. je pense que le partage y est pour beaucoup mais j'espérais un peu plus rapide étant donné que mon code est assez simplissime et que je pense pouvoir faire mieux aux niveau de la passation de paramètres... (j'avais pensé à mettre une liste des onglets à prendre, mais je me suis pas encore vraiment penché à fond dessus) 

Je rappelle que cette macro marche très bien, c'est juste qu'en partage cela mets une éternité.. la macro se base sur mes fameux onglet agent. Je pense que ma passation de paramètres 'attribuer' est convenable mais c'est le fait de recopier tout le temps le même code pour chaque feuille qui doit faire ralentir..

Sub macro_numero()

    'nom des feuilles :
    F_1 = "CF"
    F_2 = "NB"
    F_3 = "JM"
    F_4 = "Mel"
    F_5 = "MA"
    F_6 = "PL"
    F_7 = "VR"
    F_8 = "SM"
    F_9 = "MG"
    

    'Préparation de l'onglet synthèse, vide la zone de collecte des données
    Sheets("BDD").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
    'Sélectionne la feuille qu'il faut copier
    Sheets(F_1).Select
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2").Select 'sélectionne la cellule ou il faut coller
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    

    Sheets(F_2).Select 'feuille 02
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets(F_3).Select 'feuille 03
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets(F_4).Select 'feuille 04
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets(F_5).Select 'feuille 05
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets(F_6).Select 'feuille 06
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets(F_7).Select 'feuille 07
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
        Sheets(F_8).Select 'feuille 08
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets(F_9).Select 'feuille 09
    Range("J7:J89").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("BDD").Select
    Range("A2000").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    'supprimer les vides.
    'ActiveSheet.Range("A30").CurrentRegion.Select
    With Range("A2", Range("A65000").End(xlUp)). _
    SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    Sheets("Extraction").Select
    
    'affecter numéro
    numero = 1
    suivant = Worksheets("Extraction").Range("E4")
        
    Feuille = F_1
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_2
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_3
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_4
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_5
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_6
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_7
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_8
    Call attribuer(Feuille, numero, suivant)
    Feuille = F_9
    Call attribuer(Feuille, numero, suivant)


End Sub

Private Sub attribuer(Feuille, numero, suivant)
    With Worksheets(Feuille).Range("J7:J89")
        Set c = .Find("x", LookIn:=xlValues)
        If Not c Is Nothing Then
            Do
                c.Value = suivant + numero
                Set c = .FindNext(c)
                numero = numero + 1
            Loop While Not c Is Nothing
        End If
    End With
End Sub


en tout un grand merci pour le premier problème ! ;)
Je mettrais 'réponse validée' une fois que j'aurais pu avoir été aidée sur mes 3 points au cas ou quelqu'un veuille jeter un œil entre deux.

Jennifer

givemecookies · Answer

bonjour à tous !
je suis revenu du boulot donc j'ai pu me remettre dans mon fichier. Je me suis dis que le code précédent était tellement bien que je vais le ré-utlilisé j'ai donc pensé à ça :
Sub macro_numero()
    Dim Feuille As Worksheet

    LigneDestinationSurFeuilMacro = 1
    For Each Feuille In ThisWorkbook.Worksheets
        With Feuille
            If .Range("A2").Value = "Légende" Then
                Set trouver_x = .Find("x", LookIn:=xlValues) ' ça bloque ici avec " erreur de compilation :
                'Méthode ou membre de données introuvable
                    If Not trouver_x Is Nothing Then
                        Do
                            trouver_x.Value = suivant + numero
                            Set trouver_x = .FindNext(c)
                            numero = numero + 1
                        Loop While Not trouver_x Is Nothing
                    End If
            End If
        End With
    Next
End Sub

mais bon ça ne marche pas avec le .find alors que ça marchait bien dans mon code précédent.. j'ai du rater quelquechose. en tout cas je continue de chercher! n'hésitez pas à faire vos commentaires! ça peut toujours aider!
Merci encore,

Jennifer

ucfoutu · Answer

Dim trouve_x As Range
                Set trouver_x = .Range("A1:A100").Find("x", LookIn:=xlValues) ' ça bloque ici avec " erreur de compilation :

regarde ce que j'ai ajouté en rouge.
Find nécessite la définition d'une plage où cvhercher (ici, en exemple, la plager "A&:A100")
____________________
Utiliser le bouton "REPONSE ACCEPTEE" sur une réponse exacte facilite les recherches ultérieures d'autres forumeurs. PENSEZ-Y SVP

givemecookies · Answer

c'était juste un probleme de "with...end with" supplémentaire.
J'ai donc ce nouveau code qui fonctionne très bien :
Sub macro_numero()
    Dim Feuille As Worksheet
      
    '*** affecter numéro ***
    numero = 1
    suivant = Worksheets("Extraction").Range("E4")
    

   '*** trouver et attribuer les numéros ***
    For Each Feuille In ThisWorkbook.Worksheets
        With Feuille
            If .Range("A2").Value = "Légende" Then
                With Feuille.Range("J:J")
                    Set trouver_x = .Find("x") ' ça bloque ici avec " erreur de compilation :
                'Méthode ou membre de données introuvable
                
                    If Not trouver_x Is Nothing Then
                        Do
                            trouver_x.Value = suivant + numero
                            Set trouver_x = .FindNext(trouver_x)
                            numero = numero + 1
                        Loop While Not trouver_x Is Nothing
                    End If
                End With
            End If
        End With
    Next
End Sub

J'ai de plus supprimer l'onglet BDD, je prends maintenant directement sur l'onglet "Macro" . Il suffira juste de faire le premier bouton puis le 2e.

Je me penche de ce pas vers mon 3e problème :
Enfin, le 3e bouton me permet en fait de garder un 'historique' de mes commandes. J'aimerais donc qu'en appuyant sur 'supprimer' les lignes en gris clair (couleur excel 2003) s'effacent (dans les tableaux des agents) et viennent se mettre dans la feuille "Synthèse", sans effacer les 'commandes' précédentes. Je suis en ce moment même en train de me brûler des neurones là dessus. Étant donnée que la macro enregistrée pour la recherche d'une case suivant son format de couleur n'est pas vraiment fonctionnelle lorsque l'on essaye de la ré-appliquée en vba... un peu d'aide serait la bienvenue également. 
La recherche du code couleur me pose vraiment problème! si quelqu'un a une idée :) je n'ai pas de macro a vous proposer pour l'instant étant donné que la macro auto sur une recherche de couleur n'est pas terrible terrible 

voilà! Désolée du multi-post. Je vous dis dès que j'avance! (en tout cas merci pour ce code magique bigfish!)
Jennifer

givemecookies · Answer

re-bonjour,
bon à défaut de ne toujours pas avoir une macro qui marche j'avais pensé à une macro de ce genre...
Je vais essayer une nouvelle fois d'utiliser la macro magique de bigfish pour voir si ça peut être utilisé :

Sub SUPPR()
Dim Cell As Range
Dim Feuille As Worksheet

    For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier
        With Feuille
            For Each Cell In Feuille 'j'avais pensé mettre à la place de 'Feuille' mettre 'maplage' (en définissant la variable avant bien sur) peut etre que c'est plus pratique..
                If Cell.Interior.ColorIndex = 3 Then ' le gris clair basic de excel 2003 c'est quel chiffre ?
                
                End If
            Next
        End With
    Next
End Sub


Donnez moi votre avis si vous avez déjà du utiliser ce genre de code :)

ucfoutu · Answer

Réponse dans l'analyse des réponses acceptées dans cette Dicussion très récente 


____________________
Utiliser le bouton "REPONSE ACCEPTEE" sur une réponse exacte facilite les recherches ultérieures d'autres forumeurs. PENSEZ-Y SVP

givemecookies · Answer

ucfoutu,

J'ai suivi ton lien mais je n'ai pas compris le rapport, je sais maintenant comment créer une plage variable, ce que je voulais en fait c'était  : comment chercher une case avec un fond gris clair, la couper et la mettre dans l'onglet synthèse.
J'essaye de finir la plage variable pour la mettre au plus vite ici.

Merci en tout cas,
Jennifer

givemecookies · Answer

bonsoir à tous,

voilà donc l'ébauche :
Sub SUPPR()
Dim Cell As Range, derniereligne As Long, Maplage As Range
Dim Feuille As Worksheet, LigneDestinationSurFeuilMacro As Long

    LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row 
'commencer à la première ligne vide; CA BLOQUE A .Columns avec "erreur de compilation", une nouvelle fois..
    For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier
        With Feuille
            If .Range("A2").Value = "Légende" Then ' prendre seulement les onglet agent
                derniereligne = .Range("A" & .Columns("A").Rows.Count).End(xlUp).Row    'numero de la dernière ligne
                Set Maplage = .Range("A6:J" & derniereligne)                            'plage dans le tableau ou il y a des données
                Maplage.AutoFilter Field:=1, Criteria1:="<>"                            'filtrer sur les lignes non vides
                For Each Cell In Maplage
                    If Cell.Interior.ColorIndex = 3 Then ' /!\ couleur gris clair excel 2003 ?????
                Cell.SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Synthèse").Range("A" & LigneDestinationSurFeuilMacro) 'couper/coller
                LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row + 1 'la prochaine ligne de destination
                                                                                                                              'sera la ligne d'en dessous.
                Maplage.AutoFilter 'enlever le filtre
                    End If
                Next
            End If
        End With
    Next

End Sub


Je vois la fin mais je ne comprends pas pourquoi j'obtient une erreur sur columns..
Merci,

Jennifer

ucfoutu · Answer

déjà :
si tu avais lu attentivement le lien donné, tu saurais (entre autres) que
 derniereligne = .Range("A" & .Rows.Count).End(xlUp).Row  


____________________
Utiliser le bouton "REPONSE ACCEPTEE" sur une réponse exacte facilite les recherches ultérieures d'autres forumeurs. PENSEZ-Y SVP

givemecookies · Answer

déjà :
si tu avais lu attentivement le lien donné, tu saurais (entre autres) que

derniereligne = .Range("A" & .Rows.Count).End(xlUp).Row 



sauf que quand je fais ça il me met une erreur .Rows.. avec "erreur de compilation" encore..

me voilà bien embêter, je préviens si je trouve quelquechose !

Merci,
Jennifer

ucfoutu · Answer

sauf que quand je fais ça il me met une erreur .Rows.. avec "erreur de compilation" encore..

Ah oui ?
Allez ! essaye donc avec un projet neuf, un bouton de commande et le code que tu contestes !
Avec quelques lignes remplies dans la colonne A de Feuil1
Private Sub CommandButton1_Click()
  With Worksheets("Feuil1")
     derniereligne = .Range("B" & .Rows.Count).End(xlUp).Row
  End With
  MsgBox derniereligne
End Sub
Ca marche, hein ? ==>> aucune erreur à ce niveau, donc 
Plus bas dans ton code : oui ! (même type d'erreur à corriger).


____________________
Utiliser le bouton "REPONSE ACCEPTEE" sur une réponse exacte facilite les recherches ultérieures d'autres forumeurs. PENSEZ-Y SVP

givemecookies · Answer

Merci d'essayer de me dépatouiller 

j'ai mis le code comme tu me l'a suggéré mais ne fonctionne toujours pas.. ce qui est bizarre c'est que dans mes codes précédents (pour les problème 1 et 2 de mon projet ) ça marche très bien sans ta version :/

Sub SUPPR()
Dim Cell As Range, derniereligne As Long, Maplage As Range
Dim Feuille As Worksheet
Dim LigneDestinationSurFeuilMacro As Long

    LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Rows.Count).End(xlUp).Row
 'commencer à la première ligne vide
    For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier
        With Feuille
            If .Range("A2").Value = "Légende" Then ' prendre seulement les onglet agent
                derniereligne = .Range("A" & .Rows.Count).End(xlUp).Row   'numero de la dernière ligne
                Set Maplage = .Range("A6:J" & derniereligne)                            'plage dans le tableau ou il y a des données
                Maplage.AutoFilter Field:=1, Criteria1:="<>"                            'filtrer sur les lignes non vides
                For Each Cell In Maplage
                    If Cell.Interior.ColorIndex = 3 Then ' /!\ couleur gris clair excel 2003 ?????
                Cell.SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Synthèse").Range("A" & LigneDestinationSurFeuilMacro) 'couper/coller
                LigneDestinationSurFeuilMacro = Worksheets("Synthèse").Range("A" & .Rows.Count).End(xlUp).Row + 1 'la prochaine ligne de destination
                                                                                                                'sera la ligne d'en dessous.
                Maplage.AutoFilter 'enlever le filtre
                    End If
                Next
            End If
        End With
    Next

End Sub

Merci,
Jennifer

bigfish_le vrai · Answer

re,

effectivement le colorindex n'est pas 3 mais 15.

je ne sais pas si ce qu'a fait l'ami ucfoutu correspond à ton besoin, mais comme j'ai aussi bossé de mon coté, voici le code:

Sub SUPPR()
Dim Cell As Range, derniereligne As Long, Maplage As Range
Dim i As Integer
Dim Feuille As Worksheet
Dim LigneDestinationSurSynthese As Long

    
 'commencer à la première ligne vide
    For Each Feuille In ThisWorkbook.Worksheets ' Pour chaque feuille de ce fichier
        With Feuille
            If .Range("A2").Value = "Légende" Then ' prendre seulement les onglet agent
                derniereligne = .Range("A" & .Columns("A").Rows.Count).End(xlUp).Row   'numero de la dernière ligne
                Set Maplage = .Range("A7:J" & derniereligne)                            'plage dans le tableau ou il y a des données
                i = 1
                Do
                    Set Cell = Maplage.Cells(i, 1)
                    If Cell.Interior.ColorIndex = 15 Then ' /!\ couleur gris clair excel 2003 ?????
                        LigneDestinationSurSynthese = Worksheets("Synthèse").Range("A" & .Columns("A").Rows.Count).End(xlUp).Row + 1 'la prochaine ligne de destination
                        Cell.EntireRow.Copy Destination:=Worksheets("Synthèse").Range("A" & LigneDestinationSurSynthese) 'couper/coller
                        Cell.EntireRow.Delete shift:=xlUp
                    Else
                        i = i + 1
                    End If
                    DoEvents
                Loop Until i > Maplage.Rows.Count
            End If
        End With
    Next
End Sub

si ce que tu voulais est bien une suppression des lignes dans les feuilles d'agent, avec copie au préalable dans la feuille synthèse, cela devrait faire l'affaire.  C'est d'ailleurs pour cela qu'il est différent de ce que propose ucfoutu.

A+

Excel 2003 - Macro - Liste automatique - recherche suivant format couleur -

29 réponses

Votre réponse

Discussions similaires