Discussion :

[azerty1956]

merci pour ton aide jpcheck,
mais lis le message que j'ai posté ( il me semble qu'il est bien détaillé) et regarde la piece jointe et tu verras très bien que la problématique n'est pas de manipuler des couleurs.
Le problème avec mon code est qu’il ne m’affiche que 200 dans la cellule D3 sheet3 au lieu de m’afficher les 3 valeurs : 200,300,57.
Merci en tout cas pour ton message.

[Jean-Philippe André]

à vue de nez je pense qu'il faut adapter les lignes :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

with FL1.Cells(i,j).Font

en

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

FL1.Cells(i,j).Characters(Start:=2, Length:=1).Font

[azerty1956]

Je viens de tenter ça jpcheck, ça ne marche pas...

[Jean-Philippe André]

quel code as-tu écrit stp ?

[azerty1956]

voila mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Sub test4()
Dim i As Integer, j As Integer, k As Integer
Dim cle As String, CurrString As String
Dim FL1 As Worksheet 'Feuille "sheets3"
Dim FL2 As Worksheet 'Feuille "sheets1"
Dim c As Range, LigDeb As String
Dim Dtype As String
   Application.ScreenUpdating = False
'Instanciation des feuilles de calculs concernées (pour simplifier le code à venir)
     Set FL1 = Worksheets("sheets3")
     Set FL2 = Worksheets("sheets1")
    CurrString = ""
    j = 4
    Application.ScreenUpdating = False
    While FL1.Cells(1, j).Value <> ""
       
        For i = 2 To 360
'La clé est constituée de la colonne 3 d'une même ligne & de la colonne J de la ligne 1
            cle = FL1.Cells(i, 3).Value & FL1.Cells(1, j).Value
            
'Recherche de la valeur de FL1.Cells(i,3) dans la colonne F de FL2
            With FL2.Range("Y2:Y" & Split(FL2.UsedRange.Address, "$")(4))
                Set c = .Find(FL1.Cells(i, 3).Value)
                If Not c Is Nothing Then
                    LigDeb = c.Address
                    Do
                        k = c.Row
                        CurrString = FL2.Cells(k, 25).Value & FL2.Cells(k, 26).Value
                        If CurrString = cle Then
                           FL1.Cells(i, j) = FL2.Cells(k, 18)
                          'Je récupère le type qui est en colonne C
                           Dtype = FL2.Cells(k, 3)
                           With FL1.Cells(i, j).Characters(Start:=2, Length:=1).Font
                          Select Case Dtype
                           Case "LIMITS"
                               .Bold = True
                               .ColorIndex = xlAutomatic
                           Case "THRESHOLD"
                               .Bold = False
                               .ColorIndex = 3
                           Case "WARNING"
                               .Bold = False
                               .ColorIndex = 5
                           Case Else
                               .Bold = False
                               .ColorIndex = xlAutomatic
                        End Select
                       End With
                    End If

'Cette recherche ne se poursuit que si FL1.Cells(i, 1) a été trouvé
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> LigDeb
                End If
            End With
        Next i
'Ajoute une ligne à FL1
        j = j + 1
    Wend
   Application.ScreenUpdating = True
End Sub

[Jean-Philippe André]

il faut adapter la ligne proposée selon les cas, et c'est complexe à mettre en place, dans l'idée :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With FL1.Cells(i, j).Characters(Start:=1, Length:=Len(Split(FL1.Cells(i,j),chr(10))(1))).Font

[azerty1956]

Merci jpcheck

Mais a quoi correspond le

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Start:=1, Length:=Len(Split(FL1.Cells(i,j),chr(10)

??

[azerty1956]

Voila ce que j'ai quand j'utilise l'enregistreur des macros :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Macro1()
 
 
    ActiveCell.FormulaR1C1 = "23" & Chr(10) & "24" & Chr(10) & "58"
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 3
    End With
    Range("G14").Select

[Jean-Philippe André]

En fait la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ActiveCell.Characters(Start:=1, Length:=8).Font

va traiter la font des 8 caracteres en partant du 1er dans la cellule en cours.

Aussi, il va falloir retrouver les différents éléments insérés dans la cellule, connaitre leur longueur et leur emplacement dans la chaine, ce qui n'est pas une mince affaire.

Je reste sceptique sur la problématique posée, mais bon

[azerty1956]

ah okay

je suis bloqué, je ne sais plus quoi faire, si vous avez des options de recours n'hésitez pas à me les soumettre, ca serait vraiment aimable de votre part.

Je te remercie jpcheck pour tes explications.

[azerty1956]

Est ce qu'on peut changer la plage pour qu le find passe à la valeur suivante en même temps il enregistrera les différentes valeus prises sur la colonne R sheet1 qui correspondent à la cellule sheet3.
et enfin il fera une concaténation pour insérer ces valeurs dans la cellule ( comme ca au niveau visuel j'aurais 3 valeurs dans ma cellule )

????

[Qwazerty]

Salut
Alors ça a pas l'aire simple votre histoire.
Pour ma part je pense que si vous souhaitez faire un truc de ce genre, il faut reprendre votre boucle et raisonner déferrement.

Voila comment je m'y prendrais, je n'est pas Excel sous la main donc le code que j'ai mis n'est pas testé et une grosse partie est en literal a vous de la travaillé si mais solution vous semble approprié a vos besoins.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
 Sub test()
 Dim i As Integer, j As Integer, k As Integer
 Dim cle As String, CurrString As String
 Dim FL1 As Worksheet 'Feuille "Sheet3"
 Dim FL2 As Worksheet 'Feuille "Sheet1"
 Dim c As Range, LigDeb As String
 Dim ListeValeur(2) As String
    Application.ScreenUpdating = False
 'Instanciation des feuilles de calculs concernées (pour simplifier le code à venir)
      Set FL1 = Worksheets("Sheet3")
      Set FL2 = Worksheets("Sheet1")
     CurrString = ""
     j = 4
     Application.ScreenUpdating = False
     While FL1.Cells(1, j).Value <> ""
 
         For i = 2 To 360
 'La clé est constituée de la colonne 3 d'une même ligne & de la colonne J de la ligne 1
             cle = FL1.Cells(i, 3).Value & FL1.Cells(1, j).Value
             ListeValue(0) = ""
             ListeValue(1) = ""
 'Recherche de la valeur de FL1.Cells(i,3) dans la colonne F de FL2
             With FL2.Range("Y2:Y" & Split(FL2.UsedRange.Address, "$")(4))
                 Set c = .Find(FL1.Cells(i, 3).Value)
                 If Not c Is Nothing Then
                     LigDeb = c.Address
                     Do
                         k = c.Row
                         CurrString = FL2.Cells(k, 5).Value & FL2.Cells(k, 6).Value & FL2.Cells(k, 7).Value & FL2.Cells(k, 8).Value & FL2.Cells(k, 9).Value & FL2.Cells(k, 10).Value & FL2.Cells(k, 11).Value & FL2.Cells(k, 12).Value & FL2.Cells(k, 13).Value & FL2.Cells(k, 14).Value & FL2.Cells(k, 15).Value & FL2.Cells(k, 16).Value & FL2.Cells(k, 17).Value
                         If CurrString = cle Then 
                         'On memorise la valeur
                         ListeValeur(0) = FL2.Cells(k, "R") & ","
                         ListeValeur(1) = FL2.Cells(k, "C") & ","
                         'FL1.Cells(i, j) = FL2.Cells(k, 18)
 'Cette recherche ne se poursuit que si FL1.Cells(i, 1) a été trouvé
                         Set c = .FindNext(c)
                     Loop While Not c Is Nothing And c.Address <> LigDeb
                     If ListeValue(0) <> "" Then 
                         ListeValue(0) = Left(ListValue(0),Len(ListeValue(0)-1) 'Supprime le dernier ","
                         ListeValue(1) = Left(ListValue(1),Len(ListeValue(1)-1) 'Supprime le dernier ","
                     End If
                     'Maintenant il faut remplir la case en mettant en forme le text
                     'n'ayant pas excel sous la main je met la théorie a vous de chercher    
 
                     'Inscrire ListValeur(0) dans la case
                     'faire un split pour éclater les différentes valeurs stokées qui sont séparées par "," 
                     'dans ListeValeur(0) qui contient la valeur a afficher
                     'et dans ListeValeur(1) qui contient le type et donc la mise en forme du texte a faire
                     'réaliser une boucle sur chaque valeur de ListeValeur(0) avec un Select Case sur le Type
                     'retrouvé la position du text dans la case sheet3 en fonction de sa position dans ListValeur(0) et effectuer la mise en forme
                 End If
             End With
         Next i
 'Ajoute une ligne à FL1
         j = j + 1
     Wend
    Application.ScreenUpdating = True
 End Sub

En fait quand une case qui correspond aux critères est trouvés, au lieu d'être inscrite de suite dans la case correspondant, elle est stocké dans une variable, ListValeur(0), avec sa mise en page associé ListValeur(1) (si j'ai bien compris et que la colonne C correspond bien a la mise en forme du texte).
Un fois toutes les valeurs et toutes les mises en forme récupérées, il faut inscrire dans la case de la sheet3 le contenu de ListValeur(0) et le formater (ça je n'ai jamais fait, mais du code vous a été fourni plus haut, et je pense que celui ci peut s'adapter a vos besoin) la position de chaque mot (1er, 2eme,3eme donné par le split du début sur lequel vous bouclez permet de trouver la 1er et le nombre de lettre du mot afin de retrouver sa position dans la cellule).

Pas facile a expliquer mais l'idée et la je pense, ça n'est qu'une piste bon courage

Je veux bien essayer de développer un peu, mais pas avant mardi ou mercredi (sans excel c trop chaud ^^)
++
Qwaz

[azerty1956]

Merci Qwazerty pour ton courage.
Ton idée est vraiment bien, je te remercie.
Merci encore pour tous.

[Qwazerty]

Salut
Si tu as réussi a faire ce que tu voulais, essai de mettre le code sur le fil, histoire de pouvoir s'y référer pour une prochaine demande d'un internaute.
A++
Qwaz

[azerty1956]

Biensur Qwazerty

Je viens de créer une nouvelle discussion et je me disai vu ke ta bien suivi le sujet, est ce que tu pourras aller voir comment je peux insérer un commentaire avec une macro....enfin c'est plus compliqué que ca...merci d'avance.

Voila le code avec la concaténation en gras qui résout le problème:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Sub test()

Dim i As Integer, j As Integer, k As Integer
Dim cle As String, CurrString As String
Dim FL1 As Worksheet 'Feuille "sheet3"
Dim FL2 As Worksheet 'Feuille "sheet1"
Dim c As Range, LigDeb As String
Dim Dtype As String

    Sheets("Main").Range("D2:IV356").Select
    Selection.ClearContents
   Application.ScreenUpdating = False
'Instanciation des feuilles de calculs concernées (pour simplifier le code à venir)
     Set FL1 = Worksheets("sheet3")
     Set FL2 = Worksheets("sheet1")
    CurrString = ""
    j = 4
    Application.ScreenUpdating = False
    While FL1.Cells(1, j).Value <> ""
       
        For i = 2 To 360
'La clé est constituée de la colonne 3 d'une même ligne & de la colonne J de la ligne 1
            cle = FL1.Cells(i, 3).Value & FL1.Cells(1, j).Value
            
'Recherche de la valeur de FL1.Cells(i,3) dans la colonne F de FL2
            With FL2.Range("Y2:Y" & Split(FL2.UsedRange.Address, "$")(4))
                Set c = .Find(FL1.Cells(i, 3).Value)
                If Not c Is Nothing Then
                    LigDeb = c.Address
                    Do
                        k = c.Row
                        CurrString = FL2.Cells(k, 25).Value & FL2.Cells(k, 26).Value
                        If CurrString = cle Then
                            
                           FL1.Cells(i, j) = FL1.Cells(i, j) & FL2.Cells(k, 18)                          'Je récupère le type qui est en colonne C
                           Dtype = FL2.Cells(k, 3)
                           With FL1.Cells(i, j).Font
                          Select Case Dtype
                           Case "type1"
                               .Bold = True
                               .ColorIndex = xlAutomatic
                               FL1.Cells(i, j) = FL1.Cells(i, j) & "(1)"
                           Case "type2"
                               .Bold = True
                               .ColorIndex = 0
                               FL1.Cells(i, j) = FL1.Cells(i, j) & "(2)"
                           Case "type3"
                               .Bold = True
                               .ColorIndex = 0
                               FL1.Cells(i, j) = FL1.Cells(i, j) & "(3)"
                           Case Else
                               .Bold = False
                               .ColorIndex = xlAutomatic
                        End Select
                        FL1.Cells(i, j) = FL1.Cells(i, j) & vbCrLf
                       End With
                    End If

'Cette recherche ne se poursuit que si FL1.Cells(i, 1) a été trouvé
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> LigDeb
                End If
            End With
        Next i
'Ajoute une ligne à FL1
        j = j + 1
    Wend
   Application.ScreenUpdating = True


End Sub