Parcourir une plage en insérant un nombre constant de lignes

Bonjour forum,

Je suis en train de tester des solutions pour mon problème d'affichage donné dans un autre objet de message ( Affichage 4 champs- style TCD).

Je veux parcourir une colonne donnée et insérer après chaque élément de cette colonne (c'est à dire à chaque ligne) insérer un nombre constant de ligne depuis cet élément. Un nombre constant qui correspond à la taille d'un dictionnaire.

Voici mon code qui bloque au niveau de l'insertion. Il est un peu long ( Difficulté du débutant ne sachant faire court). Pourriez vous m'aider?

Public Sub essai()
       Dim i As Integer, cle As Integer, cle1 As Integer
       Dim valeur As String, valeur2 As String

       Dim r As Range, c As Range, Plage As Range

       Dim F1 As Worksheet
       Dim F2 As Worksheet
       Dim MonDico1, MonDico2
       Dim DernLigne As Integer, DernColonne As Integer
       Dim key

       Set MonDico1 = CreateObject("Scripting.Dictionary")
       Set MonDico2 = CreateObject("Scripting.Dictionary")
       Set F1 = ActiveWorkbook.Worksheets("T")
       Set F2 = ActiveWorkbook.Worksheets("V")

       cle = 1
       cle1 = 1
       DernLigne = F1.Range("A" & Rows.Count).End(xlUp).Row
       DernColonne = 1
       Set Plage = Range(Cells(1, 1), Cells(DernLigne, DernColonne))

       For Each c In Plage
              valeur = c.Value
              If Not MonDico1.Exists(valeur) Then
                  MonDico1.Add valeur, cle
                  cle = cle + 1
              End If
              valeur2 = c.Offset(, 1).Value
              If Not MonDico2.Exists(valeur2) Then
                  MonDico2.Add valeur2, cle1
                  cle1 = cle1 + 1
              End If
        Next c
       F2.[A2].Resize(MonDico1.Count, 1) = Application.Transpose(MonDico1.keys)

       Dim decalage: decalage = 1
       Dim cel As Range
       Set cel = F2.Range("B2")
       Dim d As Range

       With F2
         For Each c In F2.Range("A2").End(xlDown)
              Set d = c.Offset(, 1)
              cel.Value = MonDico2(c)
              Range(1&":"& MonDico2.count).Insert shift:=xlDown
              'd.Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
              'cel.Offset(,1).Value=

              'For Each key In MonDico2.keys
              '       cel.Offset(, 1).Value = key
              'Next i
              cel.Offset(, 1) = MonDico2.keys
              Set cel = cel.Offset(1)
          Next c
       End With

End Sub

bonjour,

une proposition, quoique je n'ai tout compris de la finalité de l'exercice

Public Sub essai()
    Dim i As Integer, cle As Integer, cle1 As Integer
    Dim valeur As String, valeur2 As String

    Dim r As Range, c As Range, Plage As Range

    Dim F1 As Worksheet
    Dim F2 As Worksheet
    Dim MonDico1, MonDico2
    Dim DernLigne As Integer, DernColonne As Integer
    Dim key

    Set MonDico1 = CreateObject("Scripting.Dictionary")
    Set MonDico2 = CreateObject("Scripting.Dictionary")
    Set F1 = ActiveWorkbook.Worksheets("T")
    Set F2 = ActiveWorkbook.Worksheets("V")

    cle = 1
    cle1 = 1
    DernLigne = F1.Range("A" & Rows.Count).End(xlUp).Row
    DernColonne = 1
    Set Plage = Range(F1.Cells(1, 1), F1.Cells(DernLigne, DernColonne))

    For Each c In Plage
        valeur = c.Value
        If Not MonDico1.Exists(valeur) Then
            MonDico1.Add valeur, cle
            cle = cle + 1
        End If
        valeur2 = c.Offset(, 1).Value
        If Not MonDico2.Exists(valeur2) Then
            MonDico2.Add valeur2, cle1
            cle1 = cle1 + 1
        End If
    Next c
    F2.[A2].Resize(MonDico1.Count, 1) = Application.Transpose(MonDico1.keys)

    Dim dlf2, tk, dc2
    With F2
        dlf2 = F2.Cells(Rows.Count, 1).End(xlUp).Row
        tk = MonDico2.keys
        dc2 = MonDico2.Count
        For i = dlf2 To 2 Step -1
            F2.Cells(i, 2) = MonDico2(F2.Cells(i, 1))
            F2.Range(i + 1 & ":" & i + dc2).Insert shift:=xlDown
            F2.Cells(i + 1, 3).Resize(dc2, 1) = Application.Transpose(tk)
        Next i
    End With

End Sub

Bonjour H2SO4,

Je vais tester la proposition. L'idée de ce que je veux faire est mis en pièce jointe dans le présent fichier. L'idée étant de l'adapter à un tableau initial aussi dynamique que l'on veut in finé.

Cordialement,

Yeshua.

Bonsoir H2SO4,

Le code fonctionne bien. J'ai ajusté le recopiage du champs 2 de sorte à commencer sur la même ligne que les données en champs 1.

Cette étape est validée du coup, merci beaucoup.

Je pense que tu as pu lire l'idée de ce que je souhaite faire. Ce n'est ps forcément le plus simple j'imagine. Dis moi ce que tu en penses stp.

Te remerciant d'avance, bien à toi,

Y.