Code : Insérer plusieurs valeurs dans une cellule

[azerty1956]

Salut,

Je suis débutant en VBA.

J'ai un fichier Excel avec deux sheets, sur la sheet 3 je récupère les données se trouvant sur la colonne R de la sheet 1.

Pour ce qui est de la structure des 2 sheets:

Dans la sheet 3 de la cell(1,4) jusqu'à la cell(1,97) j'ai un ensemble de clés, ces dernières sont les mêmes que les clés que je pourrais avoir avec les noms des cells (k,6) à (k,17) sur la sheet 1.

Pour le tableau de la sheet 3 j'ai 356 lignes pour 97 colonnes.

Pour la sheet 1 j'ai 24 colonnes et 3402 lignes. Le nombre des lignes pouvant changé sur cette sheet j’ai une boucle qui s'arrête à la dernière ligne renseignée avec un find qui s'appuie sur la comparaison entre la colonne Y de la sheet 1 et de la colonne C de la sheet 3.

Dans les cellules de ma sheet 3 je récupère les données de la colonne R de la sheet 1.

Dans le code pour chaque types (types1,2 ou 3, sur la colonne C sheet1) de valeurs prises de la colonne R de la sheet 1 on a une couleurs précise.

En effet, si vous regarder de plus près un bout de mon tableau ci-joint vous verrez que pour une seule cellule dans la sheet 3 je peux avoir plusieurs valeurs (prises de la colonne R de la sheet 1) de types différents (types définis dans la colonne C de la sheet 1). Voir ligne 2,5 et 6 de la sheet 1 où il y a que le type qui change.

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 ( avec des couleurs différentes comme défini dans le code).

J’ai utiliser l’enregistreur des macros ça me donne le code suivant :

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
End Sub

Comment je peux incorporer ça dans mon code ???

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
   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, 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 
                           FL1.Cells(i, j) = FL2.Cells(k, 18)
                          '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 "1" 
                               .Bold = True
                               .ColorIndex = xlAutomatic
                           case "2"
                               .Bold = False
                               .Colorindex = 3
                           case "3"
                               .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

NB: je suis vraiment débutant, ce code a été fait par une autre personne et je souhaitrais l'améliorer