Recap une cellule

Bonjour,

Je viens vous demander de l'aide car je suis bloqué.

En effet dans l'onglet "Analyse" pour Chaque TOTO j'ai une remontée de la fréquence, dans la population constitué en B2,B3 etc.....

Je voudrai avoir de façon Automatisé qui de la population est concerné par l'évènement en fonctions de l'onglet "Datas"

Merci de me dire si cela et faisable par une Macro

Je vous joint un fichier pour compréhension que j'ai rentré manuellement en rouge

Encore Merci de votre précieux Aide et Génie

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Merci gmb pour ta proposition

Mais ce n'est pas B1 B2 etc... qui doivent changer mais Colonne J,M,P ..... à chaque fois que le mot fréquence apparaît

si tu veux B1 B2 B3 etc... sont des Entrées

Merci beaucoup pour ton implication

cordialement

gmb un autre petit point il faut qu'il y a interaction avec l'onglet Datas

Exemple :

DECOUP034~1200 Present dans Onglet "Datas" donne

LOT_ID SLOT_ID CHAMBER

TOTO 2 DECOUP034~1200

TOTO 4 DECOUP034~1200

TOTO1 à Pour population 1,2,3,4,5 donc 2 fréquences qui donne comme résultat 2,4

TOTO2 à Pour population 2,5 donc 1 fréquence qui donne comme résultat 2

C'est les résultats que j'ai mis en Rouge dans la version V00

Encore Merci

Alors, désolé mais je n'ai rien compris.

Bye !

Merci gmb pour ton aide

Veux tu que le reformule ?

Cordialement

barachoie a écrit :

Veux tu que le reformule ?

Bye !

Merci gmb d'avoir essayé et d'avoir répondu présent.

Mesdames et Monsieurs le Post reste ouvert et merci d'apporter vos lumières, et force de propositions

bien cordialement et Merci d'avance

Bonsoir à tous,

Le code ci-dessous ne remplit que la colonne "J" de la feuille "Analyse"

Sub test()
Dim dico As Object, r As Range, w()
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Analyse")
        For Each r In .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
            dico(r.Value) = Array(.Range("b2").Value, Empty)
        Next
    End With
    With Sheets("Datas").Range("a1").CurrentRegion.Resize(, 6)
        For i = 2 To .Rows.Count
            If dico.exists(.Cells(i, 6).Value) Then
                If InStr(dico(.Cells(i, 6).Value)(0), .Cells(i, 4).Value) > 0 Then
                    w = dico(.Cells(i, 6).Value)
                    w(1) = w(1) & IIf(w(1) = Empty, Empty, ",") & .Cells(i, 4).Value
                    dico(.Cells(i, 6).Value) = w
                End If
            End If
        Next
    End With
    With Sheets("Analyse")
        For Each r In .Range("h3", .Range("h" & .Rows.Count).End(xlUp))
            r(, 3).Value = dico(r.Value)(1)
        Next
    End With
    Set dico = Nothing
End Sub

klin89

Re barachoie,

Le code réajusté :

Option Explicit
Sub test()
Dim dico As Object, i As Long, w(), e, myList
Dim rng As Range, r As Range
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    myList = Array(Array("h", "b2"), Array("k", "b3"))
    With Sheets("Analyse")
        For Each e In myList
            Set rng = .Range(e(0) & 3, .Range(e(0) & .Rows.Count).End(xlUp))
            rng.Offset(, 2).ClearContents
            For Each r In rng
                dico(r.Value) = Array(.Range(e(1)).Value, Empty)
            Next
            With Sheets("Datas").Range("a1").CurrentRegion.Resize(, 6)
                For i = 2 To .Rows.Count
                    If dico.exists(.Cells(i, 6).Value) Then
                        If InStr(dico(.Cells(i, 6).Value)(0), .Cells(i, 4).Value) > 0 Then
                            w = dico(.Cells(i, 6).Value)
                            w(1) = w(1) & IIf(w(1) = Empty, Empty, ",") & .Cells(i, 4).Value
                            dico(.Cells(i, 6).Value) = w
                        End If
                    End If
                Next
            End With
            For Each r In rng
                r(, 3).Value = dico(r.Value)(1)
            Next
            dico.RemoveAll
        Next
    End With
    Set dico = Nothing
End Sub

klin89

Klin89 Bonjour et Merci

MERCI pour cette belle démonstration et de ton génie, car tu viens d'ouvrir une Porte qui est resté très longtemps fermée

avec ta proposition qui fonctionne à Merveille !!!!!

Penses-tu qu'il serait possible d'associer nbre de ligne = Nbre de colonne

C'est à dire :

A2:B2 remplie et la suite vide donc Colonne J seul à traiter

A2:B2 et A3:B3 remplie donc colonne J et M à traiter

A2:B2 et A3:B3 et A4:B4 remplie donc colonne J M P à traiter

Ceci pour Avoir J M P S V Y AB AE AH AK ... qui ce remplisse en fonction du nombre de ligne

car mes entrées arrivent à 25 lignes parfois

Encore merci infiniment pour ton travail et la passion que tu nous transmet à travers tes Posts

Cordialement et Respect

Merci Klin89

Adaptation Code par nombre de ligne présent réalisé

super cool

Re barachoie,

Au vu de la disposition de tes données situées en feuille "Analyse", on pourrait l'écrire ainsi :

Option Explicit
Sub test()
Dim w(), i As Long, n As Byte
Dim col As Byte, premCol As Byte, derCol As Byte, lig As Byte, derLig As Byte
Dim dico As Object, rng As Range, r As Range
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Analyse")
        premCol = .Cells(1, 1).End(xlToRight).Column
        derCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For col = premCol To derCol Step 3
            If col = premCol Then n = 0 Else n = n + 2
            lig = col - 6 - n
            derLig = .Cells(.Rows.Count, col).End(xlUp).Row
            Set rng = .Range(.Cells(3, col), .Cells(derLig, col))
            rng.Offset(, 2).ClearContents
            For Each r In rng
                dico(r.Value) = Array(.Cells(lig, 2).Value, Empty)
            Next
            With Sheets("Datas").Range("a1").CurrentRegion.Resize(, 6)
                For i = 2 To .Rows.Count
                    If dico.exists(.Cells(i, 6).Value) Then
                        If InStr(dico(.Cells(i, 6).Value)(0), .Cells(i, 4).Value) > 0 Then
                            w = dico(.Cells(i, 6).Value)
                            w(1) = w(1) & IIf(w(1) = Empty, Empty, ",") & .Cells(i, 4).Value
                            dico(.Cells(i, 6).Value) = w
                        End If
                    End If
                Next
            End With
            For Each r In rng
                r(, 3).Value = dico(r.Value)(1)
            Next
            dico.RemoveAll
        Next
    End With
    Set dico = Nothing
End Sub

klin89

Merci Klin89 c'est top !!!!

Re,

Un cheminement différent :

Option Explicit
Sub test()
Dim i As Long, n As Byte
Dim col As Byte, premCol As Byte, derCol As Byte, lig As Byte, derLig As Byte
Dim dico As Object, rng As Range, r As Range
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Analyse")
        premCol = .Cells(1, 1).End(xlToRight).Column
        derCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For col = premCol To derCol Step 3
            If col = premCol Then n = 0 Else n = n + 2
            lig = col - 6 - n
            derLig = .Cells(.Rows.Count, col).End(xlUp).Row
            Set rng = .Range(.Cells(3, col), .Cells(derLig, col))
            rng.Offset(, 2).ClearContents
            With Sheets("Datas").Range("a1").CurrentRegion.Resize(, 6)
                For i = 2 To .Rows.Count
                    If InStr(Sheets("Analyse").Cells(lig, 2).Value, .Cells(i, 4).Value) > 0 Then
                        dico(.Cells(i, 6).Value) = _
                        dico(.Cells(i, 6).Value) & IIf(dico(.Cells(i, 6).Value) = Empty, Empty, ",") _
                        & .Cells(i, 4).Value
                    End If
                Next
            End With
            For Each r In rng
                'If dico.exists(r.Value) Then
                    r(, 3).Value = dico(r.Value)
                'End If
            Next
            dico.RemoveAll
        Next
    End With
    Set dico = Nothing
End Sub

klin89