Creer un rapport en fonction du remplissage de cellule

Bonjour,

J'espère que vous allez bien.

Je souhaiterai créer une macro Excel qui lorsque je la lance:

  • me créée un nouvel onglet "Rapport1" (mais si "Rapport1" existe, créer "Rapport2" etc.) ;
  • sous format un peu similaire avec une date et heure de run en cellule E1 ;
  • en me listant dans tous les onglets du classeur actif les cellules pour lesquelles il y a :
> une fond de couleur RVB (10,10,10)

> une erreur de type #REF, DIV/O etc.

Avec un lien vers ces références pour plus de facilité!

Je vous donne un exemple l'idée du rendu en PJ.

6classeur-1.xlsx (12.65 Ko)

Est- ce faisable selon vous ? Vers ou puis-je chercher / fonctions etc ?

Merci pour votre aide,

Naxos

Bonjour Naxos,

Le programme n'est pas de moi, mais cela me permet d'avoir un historique de changements sur plusieurs feuilles.

La macro créé un fichier TXT (dans le cas présent) dans l'environnement de ton bureau et nommé Rapport.txt

Libre à toi de changer le nom du fichier TXT (Exemple de Rapport à Rappor1 ou 2 ou 3 etc.).

Dès lors qu'il ne trouvera pas le dossier Rapport.txt, il en créera un autre.

Bonjour,

d'après moi c'est faisable, en clair tu vas devoir boucler sur toutes tes feuilles, sauf les rapports, et sur chacune des feuilles, chercher le format que tu recherches, et chercher les erreurs.

En clair:

Dim Wks as Worksheet
For each Wks in Sheets
    If Not Wks.Name Like "Rapport*" Then
        'ton code
    End If
Next Wks

Pour boucler sur les feuilles dont le nom ne commence pas par "Rapport"

Ensuite il te reste à chercher deux choses différentes: des erreurs, et un format

Pour ça, tu peux d'après moi utiliser la fonction Find : https://docs.microsoft.com/fr-fr/office/vba/api/excel.range.find

C'est la fonction que tu utilises avec le raccourci Ctrl + F sur Excel.

Ensuite c'est du VBA principalement, à chaque fois que tu remplis un critère, pouf, tu l'envoies dans ta feuille de synthèse, jamais à la même ligne, ça c'est simple, il faut juste incrémenter une variable contenant le numéro de ligne à chaque fois que tu écris sur le fichier.

En clair en partant sur ces bases, tu devrais commencer à avoir un programme qui ressemble à quelque chose

Merci pour vos réponses c'est super!

Je suis en train de rédiger le code, pour les erreurs c'est presque bon le rapport sort quasiment sans problème, il me manque juste à coder mais je ne sais pas faire un lien automatique vers la cellule concernée ; des idées ?

Pour ce qui concerne la recherche des cellules à fond noir RGB (10,10,10) j'ai une erreur, mon rapport ne ressort aucune cellules alors qu'il en existe, voici la partie du code qui bloque :

Set rSuivre = Nothing

On Error Resume Next

Set rSuivre = Sheets(i).UsedRange.Application.FindFormat.Interior.Color = RGB(10, 10, 10)

On Error GoTo 0

If Not rErrors Is Nothing Then

Qu'est-ce qui ne va pas avec le paramètrage ? Ici, je cherche à isoler les cellules avec fond noir!

Merci encore pour votre aide,

Naxos

Bon en triffouillant un peu j'ai réussi à m'en sortir pour le lien, il ne me manque plus qu'à lister les les cellules avec le fond noir mais je ne comprends pas pourquoi Excel ne trouve rien avec le code

Set rSuivre = Nothing
On Error Resume Next
Set rSuivre = Sheets(i).UsedRange.Application.FindFormat.Interior.Color = RGB(10, 10, 10)
On Error GoTo 0
If Not rErrors Is Nothing Then

Des idées ?

Bonjour,

Pour le findformat, j'ai cherché un peu de mon côté, il faut l'utiliser de cette façon:

Application.FindFormat.Interior.Color = RGB(10, 10, 10)
Set rSuivre = Nothing
On Error Resume Next
Set rSuivre = Sheets(i).UsedRange.Find("",SearchFormat:=true)
On Error GoTo 0
If Not rErrors Is Nothing Then

Bonjour Ausecour,

Merci pour ton aide ! Tout fonctionne parfaitement!!!

Excellente journée,

Naxos

De rien

Merci d'avoir passé le sujet en résolu

Hello Ausecours,

A n'en rien comprendre, ce qui fonctionnait ne semble pas réellement fonctionner.

Autant sur les erreurs pas de problèmes, autant sur le fonds :

Private Sub Liste_a_suivre()
  Dim rErrors As Range, r As Range
  Dim i As Long, nr As Long
  Dim sName As String

  Application.FindFormat.Interior.Color = RGB(0, 0, 0)

  Sheets.Add Before:=Sheets(1)
  nr = 1
  For i = 2 To Sheets.Count
    Set rErrors = Nothing
    On Error Resume Next
    Set rErrors = Sheets(i).UsedRange.Find("", SearchFormat:=True)
    On Error GoTo 0
    If Not rErrors Is Nothing Then
      sName = Sheets(i).Name
      For Each r In rErrors
        nr = nr + 1
        With Sheets(1)
          .Cells(nr, 1).Value = sName
          .Cells(nr, 2).Value = r.Address(0, 0)
          .Cells(nr, 3).Value = r.Text
          .Cells(nr, 4).Hyperlinks.Add Anchor:=Application.ActiveSheet.Cells(nr, 4), Address:="", SubAddress:="" & sName & "!" & r.Address(0, 0) & "", ScreenTip:="", TextToDisplay:="" & sName & "!" & r.Address(0, 0) & ""
        End With
      Next r
    End If
  Next i

  Sheets(1).Range("A1:D1").Value = Array("Feuille", "Cellule", "Follows", "Lien")
  Range("F1") = "v. " & Format(Now(), "dd/mm/yyyy") & " " & Time

Lorsque je lance la macro, ca ne me trouve qu'une valeur par feuille alors que je peux colorier toute la feuille en noir ....

Est-ce que tu as une idée ? Ai-je fauté dans le code ?

Merci pour ton aide,

Naxos

Bonjour,

ton code n'est pas totalement faux, je dirais plutôt qu'il est incomplet, Range.Find permet de trouver la première cellule remplissant le critère de recherche. Cette page en parle bien et fournit même un exemple: https://docs.microsoft.com/fr-fr/office/vba/api/excel.range.find

L'exemple donné:

With Worksheets(1).Range("a1:a500") 
    Set c = .Find(2, lookin:=xlValues) 
    If Not c Is Nothing Then 
        firstAddress = c.Address 
        Do 
            c.Value = 5 
            Set c = .FindNext(c) 
        Loop While Not c Is Nothing
    End If 
End With

permet de chercher toutes les valeurs étant égales à 2 dans la plage a1:a500, le code enregistre en premier dans c le résultat de la première recherche, puis ensuite, si la recherche renvoie bien une cellule, le code enregistre dans une variable l'adresse de la première cellule: "$A$1" par exemple, puis affecte 5 à la valeur de la cellule, et ensuite cherche la prochaine cellule correspondant au critère de recherche, et continue tant que la recherche trouve quelque chose.

L'exemple est un peu incomplet par contre, ils enregistrent l'adresse dans une variable qui ne sert plus dans la suite du code, en plus, si tu veux colorier l'intérieur d'une cellule et non changer sa valeur, alors le code tournera en boucle. Le plus simple c'est d'utiliser la variable dont ils ne se servent pas de la façon suivante:

With Worksheets(1).Range("a1:a500")
    Set c = .Find(2, LookIn:=xlValues)
    If Not c Is Nothing Then
        Do
            If c.Address <> firstAddress Then
                c.Interior.Color = RGB(150, 0, 0)
                If firstAddress = "" Then 
                    firstAddress = c.Address
                End If
                Set c = .FindNext(c)
            Else
                Set c = Nothing
            End If
        Loop While Not c Is Nothing
    End If
End With

ça demande plus de vérifications mais tu évites d'entrer dans une boucle infinie comme ça.

Hello Ausecours,

Merci pour ta réponse. J’ai essayé d’adapter ton code au miens mais cela ne fonctionne pas non plus.

L’idee est de générer un rapport avec les cellules de toutes les feuilles highlighted en noir.

En adaptant la plage à seulement a1:aaa70000 sur toutes les feuilles j’ai toujours uniquement qu’une seule référence par feuille qui est renvoyée ...

C’est dommage cela fonctionne parfaitement pour les erreurs ma boucle sur toutes les feuilles/plages

Est-ce que tu as une idée pour lister comme dans mon code toutes les cellules de toutes les feuilles highlighted en noir ?

Ce serait d’une grande aide,

Naxos

Re,

l'idée c'est de toujours utiliser un .Find pour trouver la première cellule avec Format = True, puis de faire une boucle Do Loop while pour trouver les autres cellules avec une couleur de fond noir avec un FindNext, cette idée là devrait fonctionner.

Sinon tu codes un Find manuellement, tu fais :

For Each cellule in Range("a1:aaa70000")
    If cellule.Interior.Color = rgb(0,0,0) Then
        'code
    End If
Next cellule

Hello,

J'ai repris le code mais encore un petit beug, est-ce que tu as une idée ?

                
  Private Sub Liste_a_suivre()
  Dim rErrors As Range, r As Range
  Dim i As Long, nr As Long
  Dim sName As String
  Dim c as range 

  Sheets.Add Before:=Sheets(1)
  nr = 1
  For i = 2 To Sheets.Count
    Set rErrors = Nothing
    On Error Resume Next
    Set rErrors = Sheets(i).UsedRange.Application
        For Each c In Range(Worksheets(i).Cells(1, 1), Worksheets(i).Cells.SpecialCells(xlCellTypeLastCell)).Cells
            If c.Interior.Color = rgb (0,0,0) 
            Then
      sName = Sheets(i).Name
      For Each r In rErrors
        nr = nr + 1
        With Sheets(1)
          .Cells(nr, 1).Value = sName
          .Cells(nr, 2).Value = r.Address(0, 0)
          .Cells(nr, 3).Value = r.Text
          .Cells(nr, 4).Hyperlinks.Add Anchor:=Application.ActiveSheet.Cells(nr, 4), Address:="", SubAddress:="" & sName & "!" & r.Address(0, 0) & "", ScreenTip:="", TextToDisplay:="" & sName & "!" & r.Address(0, 0) & ""
        End With
      Next r
    End If
  Next i

  Sheets(1).Range("A1:D1").Value = Array("Feuille", "Cellule", "Follows", "Lien")
  Range("F1") = "v. " & Format(Now(), "dd/mm/yyyy") & " " & Time

Merci pour ton aide,

Naxos

Re,

dur dur de dire ce qui ne fonctionne pas exactement, mais j'ai au moins vu un oubli, tu n'as pas de Next c, c'est difficile à voir parce que tu as mal fais les tabulations dans ton code

Voilà ce que ça doit donner:

Private Sub Liste_a_suivre()
Dim rErrors As Range, r As Range
Dim i As Long, nr As Long
Dim sName As String
Dim c As Range

Sheets.Add Before:=Sheets(1)
nr = 1
For i = 2 To Sheets.Count
    Set rErrors = Nothing
    On Error Resume Next
    Set rErrors = Sheets(i).UsedRange.Application
    For Each c In Range(Worksheets(i).Cells(1, 1), Worksheets(i).Cells.SpecialCells(xlCellTypeLastCell)).Cells
        If c.Interior.Color = RGB(0, 0, 0) Then
            sName = Sheets(i).Name
            For Each r In rErrors
                nr = nr + 1
                With Sheets(1)
                    .Cells(nr, 1).Value = sName
                    .Cells(nr, 2).Value = r.Address(0, 0)
                    .Cells(nr, 3).Value = r.Text
                    .Cells(nr, 4).Hyperlinks.Add Anchor:=Application.ActiveSheet.Cells(nr, 4), Address:="", SubAddress:="" & sName & "!" & r.Address(0, 0) & "", ScreenTip:="", TextToDisplay:="" & sName & "!" & r.Address(0, 0) & ""
                End With
            Next r
        End If
    Next c 'la ligne qui manquait
Next i

Sheets(1).Range("A1:D1").Value = Array("Feuille", "Cellule", "Follows", "Lien")
Range("F1") = "v. " & Format(Now(), "dd/mm/yyyy") & " " & Time

Merci pour ton retour, effectivement quelques petites frappes dans le code, il manquait également

.Cells(nr, 2).Value = C.Address(0, 0)

.Cells(nr, 3).Value = C.Text

.Cells(nr, 4).Hyperlinks.Add Anchor:=Application.ActiveSheet.Cells(nr, 4), Address:="", SubAddress:="" & sName & "!" & C.Address(0, 0) & "", ScreenTip:="", TextToDisplay:="" & sName & "!" & C.Address(0, 0) & ""

Cela fonctionne désormais! Merci pour tes lumières,

Naxos

Rechercher des sujets similaires à "creer rapport fonction remplissage"