XL 2010 création array

[alexga78]

Bonsoir le forum,

Dans le cadre d'un projet plus global, j'ai besoin de créer un array pour une utilisation ultérieure, comme ci-dessous dans l'exemple simplifié:
Données source:

Résultat souhaité:

j'ai écrit un code qui fonctionne mais loin d'être optimisé. Etant débutant, j'aimerais l'aide des experts de ce forum, histoire d'apprendre.
D'avance merci pour votre aide.

 

[mapomme]

Bonjour @alexga78 ,

Voici la version de ma pomme dans Module1 (bien d'autres sont possibles et seront peut-être suggérées).
Module2 contient le même code entièrement commenté. Si besoin, demander des éclaircissements.
Le code dans module1:

Sub UnAutreTest()
Dim derlig As Long, t, i As Long, i1 As Long, s, x, dico, clef, n As Long
   'lecture du tableau des données sources
   With Sheets("sheet1")
      If .FilterMode Then .ShowAllData
      derlig = .Cells(Rows.Count, "a").End(xlUp).Row
      t = .Range("a3:c" & derlig).Value
 
      'dictionnaire des Numéros et des numéros de lignes associées
      Set dico = CreateObject("scripting.dictionary")
      For i = 2 To UBound(t)
         If Trim(t(i, 3)) <> "" Then
            s = Split(t(i, 3), ";")
            For Each x In s
               If Trim(x) <> "" Then
                  If Not dico.exists(x) Then dico.Add x, i Else dico(x) = dico(x) & " " & i
               End If
            Next x
         End If
      Next i
 
      'le tableau final
      ReDim res(1 To dico.Count + 1, 1 To 3)
      n = 1: res(n, 1) = t(1, 3): res(n, 2) = t(1, 2): res(n, 3) = t(1, 1):
      For Each clef In dico.keys
         n = n + 1: res(n, 1) = clef
         s = Split(dico(clef))
         For Each x In s
            res(n, 2) = Trim(res(n, 2) & " " & t(CLng(x), 2))
            res(n, 3) = Trim(res(n, 3) & " " & t(CLng(x), 1))
         Next x
      Next clef
 
      'affichage et formatage
      Application.ScreenUpdating = False
      Intersect(.Range("g3").CurrentRegion, .Rows("3:" & Rows.Count), .Columns("g:i")).Clear
      With .Range("g3").Resize(UBound(res), UBound(res, 2))
         .Value = res
         .Sort key1:=.Range("a1"), order1:=xlAscending, Header:=xlYes
         .Borders.LineStyle = xlContinuous
         .HorizontalAlignment = xlCenter
         .Rows(1).Font.Bold = True
         .Rows(1).Interior.Color = RGB(200, 200, 200)
         .Columns.EntireColumn.AutoFit
      End With
   End With
End Sub

 

[alexga78]

Bonjour @mapomme, le forum,
merci beaucoup pour ton code expliqué, très utile pour un débutant comme moi.
Ta proposition est bien plus élégante que la mienne, je vais l'étudier avec attention.
Bon dimanche à toi.

 

[alexga78]

Bonsoir le forum,
j'ai modifié légèrement le code écrit par @mapomme pour rendre les données plus lisibles par les utilisateurs, en ajoutant un saut de ligne. Mon problème: un saut de ligne superflu avant mes données dû à la première boucle que je n'arrive pas à supprimer.
Merci pour votre aide.

Sub UnAutreTest()
Dim derlig As Long, t, i As Long, i1 As Long, s, x, dico, clef, n As Long
   With Sheets("sheet1")
      If .FilterMode Then .ShowAllData
      derlig = .Cells(Rows.Count, "a").End(xlUp).Row
      t = .Range("a3:c" & derlig).Value
  
      Set dico = CreateObject("scripting.dictionary")
      For i = 2 To UBound(t)
         If Trim(t(i, 3)) <> "" Then
            s = Split(t(i, 3), ";")
            For Each x In s
               If Trim(x) <> "" Then
                  If Not dico.exists(x) Then dico.Add x, i Else dico(x) = dico(x) & " " & i
               End If
            Next x
         End If
      Next i
  
      ReDim res(1 To dico.Count + 1, 1 To 3)
      n = 1: res(n, 1) = t(1, 3): res(n, 2) = t(1, 2): res(n, 3) = t(1, 1):
      For Each clef In dico.keys
         n = n + 1: res(n, 1) = clef
         s = Split(dico(clef))
         For Each x In s
            'res(n, 2) = Trim(res(n, 2) & " " & t(CLng(x), 2))
            'res(n, 3) = Trim(res(n, 3) & " " & t(CLng(x), 1))
            res(n, 2) = res(n, 2) & Chr(10) & t(CLng(x), 2)
            res(n, 3) = res(n, 3) & Chr(10) & t(CLng(x), 1)
         Next x
      Next clef
      
      Application.ScreenUpdating = False
      Intersect(.Range("g3").CurrentRegion, .Rows("3:" & Rows.Count), .Columns("g:i")).Clear
      With .Range("g3").Resize(UBound(res), UBound(res, 2))
         .Value = res
         .Sort key1:=.Range("a1"), order1:=xlAscending, Header:=xlYes
         .Borders.LineStyle = xlContinuous
         .HorizontalAlignment = xlCenter
         .Rows(1).Font.Bold = True
         .Rows(1).Interior.Color = RGB(200, 200, 200)
         .Columns.EntireColumn.AutoFit
      End With
   End With
End Sub

 

[mapomme]

Mon problème: un saut de ligne superflu avant mes données dû à la première boucle que je n'arrive pas à supprimer.

Essayez le code suivant :

Sub UnAutreTest()
Dim derlig As Long, t, i As Long, i1 As Long, s, x, dico, clef, n As Long
   'lecture du tableau des données sources
   With Sheets("sheet1")
      If .FilterMode Then .ShowAllData
      derlig = .Cells(Rows.Count, "a").End(xlUp).Row
      t = .Range("a3:c" & derlig).Value
  
      'dictionnaire des Numéros et des numéros de lignes associées
      Set dico = CreateObject("scripting.dictionary")
      For i = 2 To UBound(t)
         If Trim(t(i, 3)) <> "" Then
            s = Split(t(i, 3), ";")
            For Each x In s
               If Trim(x) <> "" Then
                  If Not dico.exists(x) Then dico.Add x, i Else dico(x) = dico(x) & " " & i
               End If
            Next x
         End If
      Next i
  
      'le tableau final
      ReDim res(1 To dico.Count + 1, 1 To 3)
      n = 1: res(n, 1) = t(1, 3): res(n, 2) = t(1, 2): res(n, 3) = t(1, 1):
      For Each clef In dico.keys
         n = n + 1: res(n, 1) = clef
         s = Split(dico(clef))
         For Each x In s
            res(n, 2) = res(n, 2) & Chr(10) & t(CLng(x), 2)
            res(n, 3) = res(n, 3) & Chr(10) & t(CLng(x), 1)
         Next x
      Next clef
      For i = 2 To UBound(res): res(i, 2) = Mid(res(i, 2), 2, 99999): res(i, 3) = Mid(res(i, 3), 2, 99999): Next
      
      'affichage et formatage
      Application.ScreenUpdating = False
      Intersect(.Range("g3").CurrentRegion, .Rows("3:" & Rows.Count), .Columns("g:i")).Clear
      With .Range("g3").Resize(UBound(res), UBound(res, 2))
         .Value = res
         .Sort key1:=.Range("a1"), order1:=xlAscending, Header:=xlYes
         .Borders.LineStyle = xlContinuous
         .HorizontalAlignment = xlCenter
         .Rows(1).Font.Bold = True
         .Rows(1).Interior.Color = RGB(200, 200, 200)
         .Columns.EntireColumn.AutoFit
         .Rows(3).Resize(UBound(res)).EntireRow.AutoFit
      End With
   End With
End Sub

 

[dysorthographie]

Bonsoir,
@mapomme l'ADD d'un dictionnaire est implicite dans ton cas, vu qu'il ne s'agit pas d'un objet, le test existe n'est pas utile !

            If Trim(x) <> "" Then
                  dico(x) = Trim(dico(x)) & " " & i
               End If

C'est juste pour info

 

[alexga78]

Bonsoir le forum,

Encore une fois un grand merci de ma pomme pour @mapomme.
Solution parfaite à mon problème.