recherche de police de la meme couleur

olive323

XLDnaute Occasionnel
Bonjour,

Ci joint un autre fichier qui j'espere sera plus explice.
Ma demande reste la meme, rechercher dans le fichier source( semaine 38) les prenoms ayants la meme couleur de police, pour ensuite les coller dans le fichier de destination (demande interim).

Merci pour votre aide

Cordialement

Olive
 

Pièces jointes

  • SEMAINE 38bis.zip
    18.9 KB · Affichages: 24
  • SEMAINE 38bis.zip
    18.9 KB · Affichages: 44
  • SEMAINE 38bis.zip
    18.9 KB · Affichages: 22

Staple1600

XLDnaute Barbatruc
Re : recherche de police de la meme couleur

Bonjour olive323

Tu sembles ne pas avoir compris le fonctionnement du forum.
Ce n'est pas la peine de récréer à chaque fois un nouveau post pour une même question.
Pour retrouver tes précédentes discussions, il te suffit d'aller dans
Liens rapides/Discussions suivies

Et la tu retrouves toutes tes discussions,tu vas alors dans celle qui tu a crée et tu te réponds à toi même (ce qu'ici on appelle "faire un petit up")

Comme cela , on peut suivre l'évolution de la discussion
(sans se perdre dans une multitude de posts traitant du même sujet)

Voici tes 3 discussions: Laquelle est la bonne ?
Discussion 1
Discussion 2
Discussion 3
 
Dernière édition:

Efgé

XLDnaute Barbatruc
Re : recherche de police de la meme couleur

Bonjour olive323, Bonjour Staple,
olive323, Je voulais regarder ton problème. Comme Staple a eu la gentillesse de donner les différents indices (fils) pour comprendre, j'ai donc suivi la piste. Mais las, cela ne suffisait pas, en plus tu édite tes anciens posts pour les remplacer par des "?".
J'abandonne, je pense que seul un chasseur de relique pourra s'y retrouver.
cordialement
 

Staple1600

XLDnaute Barbatruc
Re : recherche de police de la meme couleur

Re

olive323
En guise de piste de départ et de source d'inspiration

Code:
Sub b()
Dim ep1, t$, vert&, c As Range
ep1 = MsgBox("On recherche la police en Vert?", vbQuestion + vbYesNo, "Test 1")
If ep1 = vbYes Then
With Sheets(1)
vert = [E11].Font.ColorIndex
    For Each c In .UsedRange
        If c.Font.ColorIndex = vert Then
        t = t & c & " : " & c.Address(0, 0) & vbLf
        End If
    Next c
End With
MsgBox Left(t, Len(t) - 1), vbInformation, "Résultats"
Else
End
End If
End Sub
 

Efgé

XLDnaute Barbatruc
Re : recherche de police de la meme couleur

Bonjour olive323, JHA, Staple1600, le forum
Une proposition qui extrait une liste avec les valeurs de même couleur de police par date et le motif d'absence.
Code:
[COLOR=blue]Private Sub[/COLOR] CommandButton1_Click()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
[COLOR=blue]Set[/COLOR] mondico = CreateObject("Scripting.Dictionary")
Derligne = [a65000].End(xlUp).Row
Dercol = Cells(2, Application.Columns.Count).End(xlToLeft).Column - 2
Sheets("demande interim").Cells.Delete
[COLOR=blue]For[/COLOR] j = 5 [COLOR=blue]To[/COLOR] Dercol [COLOR=blue]Step[/COLOR] 7
    [COLOR=blue]Set[/COLOR] plg = Range(Cells(2, j), Cells(Derligne, j))
    [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] plg
        [COLOR=blue]If[/COLOR] c.Font.ColorIndex <> -4105 [COLOR=blue]Then[/COLOR] mondico.Item(c.Font.ColorIndex) = c.Font.ColorIndex
    [COLOR=blue]Next[/COLOR] c
    Temp = mondico.Items
    [COLOR=blue]For[/COLOR] k = 0 [COLOR=blue]To UBound[/COLOR](Temp)
        z = 0
        [COLOR=blue]ReDim[/COLOR] Temp2(0 [COLOR=blue]To[/COLOR] Derligne, 1 [COLOR=blue]To[/COLOR] 3)
        [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] plg
            [COLOR=blue]If[/COLOR] c.Font.ColorIndex = Temp(k) [COLOR=blue]And[/COLOR] c.Value <> "" [COLOR=blue]Then[/COLOR]
                Temp2(z, 1) = Cells(1, j - 4).Value
                Temp2(z, 2) = c.Value
                Temp2(z, 3) = c.Offset(0, 1).Value
                z = z + 1
            [COLOR=blue]End If[/COLOR]
        [COLOR=blue]Next[/COLOR] c
        [COLOR=blue]If[/COLOR] z <> 0 [COLOR=blue]Then[/COLOR]
            [COLOR=blue]With[/COLOR] Sheets("demande interim")
                Lrow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                [COLOR=blue]If[/COLOR] .Cells(1, 1) = "" [COLOR=blue]Then[/COLOR] Lrow = 1
                [COLOR=blue]With[/COLOR] .Cells(Lrow, 1).Resize([COLOR=blue]UBound[/COLOR](Temp2), 3)
                    .Value = Temp2
                    .Font.ColorIndex = Temp(k)
                [COLOR=blue]End With[/COLOR]
            [COLOR=blue]End With[/COLOR]
        [COLOR=blue]End If[/COLOR]
    [COLOR=blue]Next[/COLOR] k
[COLOR=blue]Next[/COLOR] j
Sheets("demande interim").Activate
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
Cordialement
 

Pièces jointes

  • Extraire_FontColor.zip
    23.6 KB · Affichages: 22

Efgé

XLDnaute Barbatruc
Re : recherche de police de la meme couleur

Re
Une version définitive (enfin :rolleyes: pour moi...) qui rempli les demandes d'interims automatiquement.
Cordialement
EDIT J'avais raison de douter ...
Changement du fichier suite à modif du code (plus court et surtout plus logique.
Code:
[COLOR=blue]Private Sub[/COLOR] CommandButton1_Click()
Application.ScreenUpdating = [COLOR=blue]False[/COLOR]
w = 4
[COLOR=blue]Set[/COLOR] mondico = CreateObject("Scripting.Dictionary")
Derligne = [a65000].End(xlUp).Row
Dercol = Cells(2, Application.Columns.Count).End(xlToLeft).Column - 2
[COLOR=blue]For[/COLOR] i = 4 [COLOR=blue]To[/COLOR] 99 [COLOR=blue]Step[/COLOR] 19
    Sheets("demande interim").Rows(i).ClearContents
[COLOR=blue]Next[/COLOR] i
[COLOR=blue]For[/COLOR] j = 5 [COLOR=blue]To[/COLOR] Dercol [COLOR=blue]Step[/COLOR] 7
    [COLOR=blue]Set[/COLOR] plg = Range(Cells(2, j), Cells(Derligne, j))
    [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] plg
        [COLOR=blue]If[/COLOR] c.Font.ColorIndex <> -4105 [COLOR=blue]And[/COLOR] c.Value <> "" [COLOR=blue]Then[/COLOR] mondico.Item(c.Font.ColorIndex) = c.Font.ColorIndex
    [COLOR=blue]Next[/COLOR] c
    Temp = mondico.Items
    [COLOR=blue]For[/COLOR] k = 0 [COLOR=blue]To UBound[/COLOR](Temp)
        z = 0
        [COLOR=blue]ReDim[/COLOR] Temp2(0 [COLOR=blue]To[/COLOR] Derligne, 1 [COLOR=blue]To[/COLOR] 3)
        [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] plg
            [COLOR=blue]If[/COLOR] c.Font.ColorIndex = Temp(k) [COLOR=blue]And[/COLOR] c.Value <> "" [COLOR=blue]Then[/COLOR]
                Temp2(z, 1) = Cells(1, j - 4).Value
                Temp2(z, 2) = c.Value
                Temp2(z, 3) = c.Offset(0, 1).Value
                z = z + 1
            [COLOR=blue]End If[/COLOR]
        [COLOR=blue]Next[/COLOR] c
        [COLOR=blue]With[/COLOR] Sheets("demande interim")
            [COLOR=blue]For[/COLOR] i = [COLOR=blue]LBound[/COLOR](Temp2) [COLOR=blue]To UBound[/COLOR](Temp2)
                [COLOR=blue]If[/COLOR] Temp2(i, 3) = "" [COLOR=blue]Then[/COLOR]
                    .Cells(w, 1) = Temp2(i, 2)
                [COLOR=blue]Else[/COLOR]
                    .Cells(w, 5) = Temp2(i, 2)
                    .Cells(w, 6) = "En " & Temp2(i, 3)
                    .Cells(w, 3) = "en remplacement de "
                [COLOR=blue]End If[/COLOR]
            [COLOR=blue]If[/COLOR] .Cells(w, 1) <> "" [COLOR=blue]And[/COLOR] .Cells(w, 5) <> "" [COLOR=blue]Then[/COLOR] w = w + 19
            [COLOR=blue]Next[/COLOR] i
        [COLOR=blue]End With[/COLOR]
    [COLOR=blue]Next[/COLOR] k
    mondico.RemoveAll
[COLOR=blue]Next[/COLOR] j
Application.ScreenUpdating = [COLOR=blue]True[/COLOR]
[COLOR=blue]End Sub[/COLOR]
 

Pièces jointes

  • Extraire_FontColor(2).zip
    26.4 KB · Affichages: 25
Dernière édition:

Efgé

XLDnaute Barbatruc
Re : recherche de police de la meme couleur

Bonjour le fil, le forum,
Comme je suis tétu, j'ai "amélioré" ma proposition :
- 0.09 seconde pour sept jours et 45 bordereaux remplis
- possibilité d'utiliser le code dans un module
Code:
[COLOR=blue]Private Sub[/COLOR] CommandButton1_Click()
[COLOR=blue]Set[/COLOR] F1 = ActiveSheet
[COLOR=blue]Set[/COLOR] F2 = Sheets("demande interim")
[COLOR=blue]Set[/COLOR] mondico = CreateObject("Scripting.Dictionary")
w = 4
[COLOR=blue]For[/COLOR] i = 4 [COLOR=blue]To[/COLOR] 156 [COLOR=blue]Step[/COLOR] 19
    F2.Rows(i).ClearContents
[COLOR=blue]Next[/COLOR] i
[COLOR=blue]With[/COLOR] F1
    Derligne = .Cells(Rows.Count, 1).End(xlUp).Row
    Dercol = .Cells(2, Columns.Count).End(xlToLeft).Column - 2
    [COLOR=blue]For[/COLOR] j = 5 [COLOR=blue]To[/COLOR] Dercol [COLOR=blue]Step[/COLOR] 7
        [COLOR=blue]Set[/COLOR] plg = .Range(Cells(3, j), Cells(Derligne, j))
        [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] plg
            [COLOR=blue]If[/COLOR] c.Font.ColorIndex <> -4105 [COLOR=blue]And[/COLOR] c.Value <> "" [COLOR=blue]Then[/COLOR] mondico.Item(c.Font.ColorIndex) = c.Font.ColorIndex
        [COLOR=blue]Next[/COLOR] c
        [COLOR=blue]For Each[/COLOR] k [COLOR=blue]In[/COLOR] mondico.Keys
            [COLOR=blue]ReDim[/COLOR] Temp(1 [COLOR=blue]To[/COLOR] 6)
            [COLOR=blue]For Each[/COLOR] c [COLOR=blue]In[/COLOR] plg
                [COLOR=blue]If[/COLOR] c.Font.ColorIndex = mondico(k) [COLOR=blue]And[/COLOR] c.Value <> "" [COLOR=blue]Then[/COLOR]
                    [COLOR=blue]If[/COLOR] c.Offset(0, 1).Value = "" [COLOR=blue]Then[/COLOR]
                        Temp(1) = c.Value
                        Temp(3) = "en remplacement de "
                    [COLOR=blue]Else[/COLOR]
                        Temp(5) = c.Value
                        Temp(6) = "En " & c.Offset(0, 1).Value
                    [COLOR=blue]End If[/COLOR]
                [COLOR=blue]End If[/COLOR]
            [COLOR=blue]Next[/COLOR] c
            F2.Cells(w, 1).Resize([COLOR=blue]LBound[/COLOR](Temp), [COLOR=blue]UBound[/COLOR](Temp)) = Temp
            w = w + 19
        [COLOR=blue]Next[/COLOR] k
        mondico.RemoveAll
    [COLOR=blue]Next[/COLOR] j
[COLOR=blue]End With[/COLOR]
F2.Activate
[COLOR=blue]End Sub[/COLOR]
Cordialement
 

Pièces jointes

  • Extraire_FontColor(3).zip
    27.9 KB · Affichages: 18

Discussions similaires

Réponses
17
Affichages
611

Statistiques des forums

Discussions
311 705
Messages
2 081 733
Membres
101 807
dernier inscrit
foued