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 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.
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