XL 2013 Transfert dico dans un range discontinue

[Regueiro]

Bonsoir le Forum
J'aimerais copier dans un range discontinue les valeurs de mondico
La plage de destination PlageChoix comporte 15 cellules comme les 15 de mondico.

voici le code :

Option Explicit
Option Compare Text
Sub Proc111()
Dim Maliste2 As ListObject
Dim FDO As Worksheet
Dim FSOUD As Worksheet
Dim Result
Dim PlageChoix()
Dim C As Range
Dim Plage As Variant
Dim Cel As Range
Dim temp
Dim MonDico As Scripting.Dictionary
Dim a As Long
Dim i%
Set FDO = Sheets("DONNEES")
Set FSOUD = Worksheets("SOUDURE_ANGLE")
Set Maliste2 = FDO.ListObjects("Tableau3")
PlageChoix = Array(FDO.Range("D42:D44"), FDO.Range("D46:D48"), FDO.Range("I46:I48"), FDO.Range("D50:D52"), FDO.Range("I50:I52"))
'Set choix = FSOUD.Range("D42:D44,D46:D48,I46:I48,D50:D52,I50:I52")

Set MonDico = New Dictionary

Result = FSOUD.OLEObjects("ComboBox1").Object.Value
MsgBox Left(Result, 3)
For Each C In Maliste2.DataBodyRange.Columns(1).Cells
        If C.Text = Left(Result, 3) Then MonDico(C.Offset(, 1).Value) = "" ' si famille alors on ajoute l'élément de la sous-famille au dictionnaire

For i = 0 To 4
MsgBox PlageChoix(i).Address
For Each Plage In PlageChoix(i)
    For Each Cel In Plage.Cells
           For a = 1 To MonDico.Count
              Cel.Item(a) = MonDico.Keys(a - 1)
    Next a
    Next Cel
Next Plage
Next i

 

[Regueiro]

Re : Transfert dico dans un range discontinue

REBONSOIR
Voici le code qui fonctionne moi :

Option Explicit
Option Compare Text
Sub Proc111()
Dim Maliste2 As ListObject
Dim FDO As Worksheet
Dim FSOUD As Worksheet
Dim Result
Dim PlageChoix
Dim C As Range
Dim Plage As Variant
Dim MonDico As Scripting.Dictionary
Dim a As Long

Set FDO = Sheets("DONNEES")
Set FSOUD = Worksheets("SOUDURE_ANGLE")
Set Maliste2 = FDO.ListObjects("Tableau3")
Set PlageChoix = FSOUD.Range("D42:D44,D46:D48,I46:I48,D50:D52,I50:I52")
Set MonDico = New Dictionary

Result = FSOUD.OLEObjects("ComboBox1").Object.Value
MsgBox Left(Result, 3)
For Each C In Maliste2.DataBodyRange.Columns(1).Cells
        If C.Text = Left(Result, 3) Then MonDico(C.Offset(, 1).Value) = "" ' si famille alors on ajoute l'élément de la sous-famille au dictionnaire
 Next C

MsgBox MonDico.Count

Set Plage = PlageChoix.Areas
MsgBox Plage(1).Address
MsgBox Plage(5).Address

   For a = 1 To 3  'Chaque plage a 3 cellules
        Plage(1).Item(a).Value = MonDico.Keys(a - 1)    '-1 keys 0 to 2
        Plage(2).Item(a).Value = MonDico.Keys(a + 2)    '+2 keys 3 to 5
        Plage(3).Item(a).Value = MonDico.Keys(a + 5)
        Plage(4).Item(a).Value = MonDico.Keys(a + 8)
        Plage(5).Item(a).Value = MonDico.Keys(a + 11)
    Next a
    
Set FDO = Nothing
Set FSOUD = Nothing
Set Maliste2 = Nothing
Set PlageChoix = Nothing
Set MonDico = Nothing
End Sub

Je pense que l'on peut encore améliorer ce code ?

Set Plage = PlageChoix.Areas
MsgBox Plage(1).Address
MsgBox Plage(5).Address

   For a = 1 To 3  'Chaque plage a 3 cellules
        Plage(1).Item(a).Value = MonDico.Keys(a - 1)    '-1 keys 0 to 2
        Plage(2).Item(a).Value = MonDico.Keys(a + 2)    '+2 keys 3 to 5
        Plage(3).Item(a).Value = MonDico.Keys(a + 5)
        Plage(4).Item(a).Value = MonDico.Keys(a + 8)
        Plage(5).Item(a).Value = MonDico.Keys(a + 11)
    Next a

@+

 

[Dranreb]

Re : Transfert dico dans un range discontinue

Bonsoir.
Pourrait on voir le classeur ?

 

[Regueiro]

Re : Transfert dico dans un range discontinue

BONSOIR LE FORUM - DANREB
Je ne peux malheureusement pas transmettre le fichier actuellement.
La Procédure du Post N° 2 fait partie d'un petit que programme que je mets en place actuellement.

https://www.excel-downloads.com/threads/calcul-cout-soudure-et-volume.20005502/

Mon soucis était d'alimenter les ranges discontinues mais j'ai trouver une solution.
Maintenant peut-on simplifier ce code ?

Set Plage = PlageChoix.Areas
MsgBox Plage(1).Address
MsgBox Plage(5).Address

   For a = 1 To 3  'Chaque plage a 3 cellules
        Plage(1).Item(a).Value = MonDico.Keys(a - 1)    '-1 keys 0 to 2
        Plage(2).Item(a).Value = MonDico.Keys(a + 2)    '+2 keys 3 to 5
        Plage(3).Item(a).Value = MonDico.Keys(a + 5)
        Plage(4).Item(a).Value = MonDico.Keys(a + 8)
        Plage(5).Item(a).Value = MonDico.Keys(a + 11)
    Next a

Si j'ai un moment je mets ça sur un autre fichier.
Merci.
@+

 

[Dranreb]

Re : Transfert dico dans un range discontinue

Bonsoir.
Le simplifier je ne sais pas, le rendre plus performant sûrement.
Keys est pénalisant pour accéder positionnellement à des clés isolées. Il vaut mieux d'abord en prendre une copie dans un tableau, et les extraire de celui-ci.
Après, moi j'ai tendance à éviter de modifier des cellules individuelles, je préfère copier de tableau à tableau et décharger ceux là dans les Value de Range de plusieurs cellules. S'il n'y a pas de formule dans le coin, je travaillerais carrément avec un tableau image de D42:I52. S'il n'y a aucune formule dans la feuille je ne prévoirais que deux accès aux cellules en tout et pour tout: un chargement de toute la UsedRange.Value au début, et un déchargement de toute la UsedRange.Value à la fin. C'est toujours plus performant. Un seul chargement/déchargement de plusieurs dizaines de milliers de cellules est amorti pour plus d'à peine une vingtaine de chargements/déchargements d'une seule cellule.

 

[BOISGONTIER]

Re : Transfert dico dans un range discontinue

Bonjour,

Exemple en PJ

Sub decoupeDico()
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To 12: d(i) = "": Next
  '--- découpe
  pas = 3
  For k = 0 To d.Count / pas - 1
    decal = k * pas + 1
    [C1].Resize(pas).Offset(k * (pas + 1)) = Application.Index(d.keys, Evaluate("Row(" & decal & ":" & decal + pas & ")"))
  Next k
End Sub

ou

Sub decoupeDico()
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To 12: d(i) = "": Next
  '--- découpe
  pas = 3
  a = d.keys
  For k = 0 To d.Count / pas - 1
    decal = k * pas + 1
    [C1].Resize(pas).Offset(k * (pas + 1)) = Application.Index(a, Evaluate("Row(" & decal & ":" & decal + pas & ")"))
  Next k
End Sub

JB