Notion de volume, VBA

[Edd93]

Bonjour à vous !


Voici un fichier en PJ, et sur ce fichier, on a des palettes x, y, z, avec deux boutons qui permettent le déplacemen de ces palettes à travers des cellules.
J'aimerai intégrer une notion de volume. Est-il possible de doubler par exemple le contenu d'une cellule de sorte à ce que la palette x se trouve, lorsqu'on clique sur le boutons, sur deux cellules et non une seule.
Merci de votre compréhension !

 

[Edd93]

Voilà le fichier

 

[Edd93]

Au pire des cas, intégrer la possibilité de mettre un ou plusieurs cellules dans la colonne i,3

du genre

colonne 2
A3
colonne 3
B6; B49

Le contenu de A3 va dans B6 et B49

 

[vgendron]

Bonjour

voir PJ pour exemple
j'ai ajouté une colonne D (Poids) qui représente le nombre de cellules qu'occupe la palette
et voir macros 2
la macro init est la pour réinitialiser car si tu cliques deux fois de suite sur la meme macro, tes datas sont effacées.

 

[Edd93]

Bonjour,merci déjàdem'avoir répondu !

je n'arrive pas vraiment à comprendre tonfichier car, nous ne savons pas où va par exemple la palette1 et où elle se situe initialement, dans ton fichier la palette1 se trouve à B2 et B3 hors que j'ai spécifié qu'elle doit se trouver seulement sur une cellule initialement, et qu'à la suite, en cliquant sur le bo

 

[vgendron]

Avec un bouton qui permet de basculer d'une position à l'autre

d'ailleurs.. pour le déplacement vers l'arrivée, on pourrait se passer des couper coller.. et faire comme l'init. avec les adresses de destination..
à voir selon l'utilisation finale

 

[Edd93]

est-il possible simplement de mettre deux destinations dans une cellule ? c'est à dire dans une cellule de la colonne i, 3 mettre A14; B65 par exemple, ou bien créer des colonnes 4,5,6 qui correspondent à des destination 2,3,4 c'est plus simple je pense.

 

[vgendron]

bon. je ne vois pas bien comment une palette peut prendre plus de place juste en la déplaçant. mais bon. pourquoi pas..
donc.
en supposant qu'au départ, une palette = 1 cellule
à l'arrivée. la meme palette peut prendre un nombre différent de cellules (colonne Poids)

avec ces macro

Sub Init_Palette()
Dim f1 As Worksheet, f2 As Worksheet
Dim i%: i = 2
Dim Départ$, Arrivée$, Poids, Nom

Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
f1.Cells.Clear
With f2
    Do While .Cells(i, 2).Value <> ""
        Nom = .Cells(i, 1): Départ = .Cells(i, 2).Value ': Arrivée = .Cells(i, 3).Value: Poids = .Cells(i, 4).Value
        f1.Range(Départ) = Nom
        i = i + 1
    Loop
End With

End Sub

Sub Deplacement2_Palette()
Dim f1 As Worksheet, f2 As Worksheet
Dim i%: i = 2
Dim Départ$, Arrivée$, Poids, Nom


Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
f1.Cells.Clear
With f2
    Do While .Cells(i, 2).Value <> ""
        Nom = .Cells(i, 1): Arrivée = .Cells(i, 3).Value: Poids = .Cells(i, 4).Value
        f1.Range(Arrivée).Resize(Poids) = Nom
        i = i + 1
    Loop
End With

End Sub

 

[Edd93]

Enfaite c'est parce'que la palette1 lorsqu'elle est pleine, est de suite remplacé, c'est pourquoi ça doit rester seulement une cellule

 

[Edd93]

Voilà en PJ deux exemples de ce que je souhaite concrètement, mais je préfère plus l'image pb1

 

[vgendron]

avec ce fichier,
il suffit de placer les adresses d'arrivée, séparées d'une virgule

précédemment, j'avais présumé que la palette pouvait se placer sur plusieurs cellules qui se suivent..

 

[Edd93]

Merci beaucoup on est proche du but, mais les cellules des palettes sont colorées, hors dans la feuille1 les palettes ne sont pas colorées, peut-on arranger ça ?

 

[vgendron]

voici

Sub Init_Palette()
Dim f1 As Worksheet, f2 As Worksheet
Dim i%: i = 2
Dim Départ$, Arrivée$, Poids, Nom

Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
f1.Cells.Clear
With f2
    Do While .Cells(i, 2).Value <> ""
        Nom = .Cells(i, 1): Départ = .Cells(i, 2).Value ': Arrivée = .Cells(i, 3).Value: Poids = .Cells(i, 4).Value
        f1.Range(Départ) = Nom
        f1.Range(Départ).Interior.Color = RGB(255, 255, 0)
       
        i = i + 1
    Loop
End With

End Sub

Sub Deplacement2_Palette()
Dim f1 As Worksheet, f2 As Worksheet
Dim i%: i = 2
Dim j As Integer
Dim Départ$, Arrivée$, Nom


Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
'on efface la feuille
f1.Cells.Clear

With f2
    Do While .Cells(i, 2).Value <> ""
        'on récupère le nom de la palette
        Nom = .Cells(i, 1)
        'on récupère la liste des adresses d'arrivée
        Arrivée = .Cells(i, 3).Value
        'avec le séparateur "," on en fait un tableau
        tabArrivée = Split(Arrivée, ",")
        'pour chaque adresse, on met le nom de la palette
        For j = LBound(tabArrivée) To UBound(tabArrivée)
            f1.Range(tabArrivée(j)) = Nom
            f1.Range(tabArrivée(j)).Interior.Color = RGB(255, 255, 0)
        Next j
        i = i + 1
    Loop
End With

End Sub

'Sub Retour2_Palette()
'Dim f1 As Worksheet, f2 As Worksheet
'Dim i%: i = 2
'Dim Départ$, Arrivée$, Poids, Nom
'
'Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
'
'With f2
'    Do While .Cells(i, 2).Value <> ""
'        Nom = .Cells(i, 1): Départ = .Cells(i, 2).Value: Arrivée = .Cells(i, 3).Value: Poids = .Cells(i, 4).Value
'        f1.Range(Arrivée).Resize(Poids).Cut f1.Range(Départ)
'        i = i + 1
'    Loop
'End With
'
'End Sub

Sub Caseàcocher4_Clic()

If [G12] = False Then
    Deplacement2_Palette
    ActiveSheet.Shapes("Check Box 4").Select
    Selection.Characters.Text = "Replacer au départ"
    [A1].Select
   
Else
    Init_Palette
    ActiveSheet.Shapes("Check Box 4").Select
    Selection.Characters.Text = "Déplacer vers arrivée"
    [A1].Select
End If
End Sub

 

[vgendron]

et comme je suis prêt à parier que tu vas me dire que les palettes peuvent avoir des couleurs différentes ;-)

Sub Init_Palette()
Dim f1 As Worksheet, f2 As Worksheet
Dim i%: i = 2
Dim Départ$, Arrivée$, Nom, Couleur

Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
f1.Cells.Clear
With f2
    Do While .Cells(i, 2).Value <> ""
        Nom = .Cells(i, 1): Départ = .Cells(i, 2).Value: Couleur = .Cells(i, 1).Interior.ColorIndex ': Poids = .Cells(i, 4).Value
        f1.Range(Départ) = Nom
        f1.Range(Départ).Interior.ColorIndex = Couleur 'RGB(255, 255, 0)
       
        i = i + 1
    Loop
End With

End Sub

Sub Deplacement2_Palette()
Dim f1 As Worksheet, f2 As Worksheet
Dim i%: i = 2
Dim j As Integer
Dim Départ$, Arrivée$, Nom, Couleur


Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
'on efface la feuille
f1.Cells.Clear

With f2
    Do While .Cells(i, 2).Value <> ""
        'on récupère le nom de la palette
        Nom = .Cells(i, 1)
        'on récupère la couleur de la palette
        Couleur = .Cells(i, 1).Interior.ColorIndex
        'on récupère la liste des adresses d'arrivée
        Arrivée = .Cells(i, 3).Value
        'avec le séparateur "," on en fait un tableau
        tabArrivée = Split(Arrivée, ",")
        'pour chaque adresse, on met le nom de la palette
        For j = LBound(tabArrivée) To UBound(tabArrivée)
            f1.Range(tabArrivée(j)) = Nom
            f1.Range(tabArrivée(j)).Interior.ColorIndex = Couleur
        Next j
        i = i + 1
    Loop
End With

End Sub

'Sub Retour2_Palette()
'Dim f1 As Worksheet, f2 As Worksheet
'Dim i%: i = 2
'Dim Départ$, Arrivée$, Poids, Nom
'
'Set f1 = Sheets("Feuil1"): Set f2 = Sheets("Feuil2")
'
'With f2
'    Do While .Cells(i, 2).Value <> ""
'        Nom = .Cells(i, 1): Départ = .Cells(i, 2).Value: Arrivée = .Cells(i, 3).Value: Poids = .Cells(i, 4).Value
'        f1.Range(Arrivée).Resize(Poids).Cut f1.Range(Départ)
'        i = i + 1
'    Loop
'End With
'
'End Sub

Sub Caseàcocher4_Clic()

If [G12] = False Then
    Deplacement2_Palette
    ActiveSheet.Shapes("Check Box 4").Select
    Selection.Characters.Text = "Replacer au départ"
    [A1].Select
   
Else
    Init_Palette
    ActiveSheet.Shapes("Check Box 4").Select
    Selection.Characters.Text = "Déplacer vers arrivée"
    [A1].Select
End If
End Sub

 

[Edd93]

Je n'arrive pas à faire fonctionner pouvez vous m'envoyer le fichier ?