VBA organiser la copie d'éléments

Version imprimable

09/05/2018, 09h37
SEBJAK

1 pièce(s) jointe(s)

VBA organiser la copie d'éléments

Bonjour

pourriez vous m'aider ?
je souhaiterais dans ma macro organiser la copie de mes objets

lorsque la macro colle l'objet sur un autre onglet, je souhaiterais qu'il le place en dessous du précédent et non pas sur le précédent

je vous joint mon début de fichier

D'avance merci pour votre aide
09/05/2018, 09h57
jerome.vaussenat

Salut,

Les fichiers avec macros n'ont pas la cote ici. Pour des raisons de sécurité ...

Plutôt que de mettre ton fichier, merci de mettre le code à optimiser. Sans oublier de le mettre dans la balise prévue à cet effet. C'est le bouton # dans la barre d'outil de rédaction de ton message.

Merci de ta compréhension. Et là, je pense que tu auras plus d'aide. De plus, cela fait partie des règles du forum ...
cf https://www.developpez.net/forums/d8...s-discussions/

Voici le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Sub alimentation()
 
Dim lig As Integer
Dim trvLig As Boolean
Dim maxL As Integer
Dim text As String
Dim desc As String
 
ActiveSheet.DrawingObjects("titre").text = ""
ActiveSheet.DrawingObjects("description").text = ""
lig = 6
trvLig = True
debut = 6
a = debut
 
While trvLig = True
    If Feuil1.Cells(lig, 2) <> "" Then
        maxL = maxL + 1
        lig = lig + 1
    Else
        maxL = maxL
        trvLig = False
    End If
Wend
 
maxLigne = maxL
 
MsgBox maxLigne, vbInformation
 
 
For lig = 1 To maxL
'
 
    text = Range("B" & a).Value
 
    ActiveSheet.Shapes.Range(Array("titre")).Select
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.text = text
 
    desc = Range("C" & a).Value
 
    ActiveSheet.Shapes.Range(Array("description")).Select
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.text = desc
 
    ActiveSheet.Shapes.Range(Array("bloc 1")).Select
 
 
 ActiveSheet.Shapes.Range(Array("groupe 2")).Select
    Selection.Copy
    Sheets("Feuil2").Select
    Range("A4").Select
    ActiveSheet.Paste
 
    Sheets("Feuil1").Select
 
  a = a + 1
 
        Next
 
End Sub