XL 2013 Transfert dico dans un range discontinue

Regueiro · 28 Février 2016

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 :

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 · 28 Février 2016

Re : Transfert dico dans un range discontinue

REBONSOIR
Voici le code qui fonctionne moi :

HTML:

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 ?

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 · 28 Février 2016

Re : Transfert dico dans un range discontinue

Bonsoir.
Pourrait on voir le classeur ?

Regueiro · 29 Février 2016

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 ?

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 · 1 Mars 2016

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 · 1 Mars 2016

Re : Transfert dico dans un range discontinue

Bonjour,

Exemple en PJ

Code:

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

Code:

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

XL 2013 Transfert dico dans un range discontinue

Regueiro

XLDnaute Impliqué

Regueiro

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

Regueiro

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

XL 2013 Transfert dico dans un range discontinue

Regueiro

XLDnaute Impliqué

Regueiro

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

Regueiro

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency