Etendre macro à l'ensemble d'une selection

Version imprimable

04/11/2014, 17h37
nonodudu77

1 pièce(s) jointe(s)

Etendre macro à l'ensemble d'une selection

Bonjour,

J'ai réalisé une macro afin que mes données ici mon tableau 1 "ligne 1 à 12" me génère automatiquement de multiples tableaux (un tableau pour chaque ligne de mon 1er tableau).

Actuellement, je dois me mettre sur la cellule A1 du tableaux et cliquer sur le bouton GO pour générer le second tableau pour la ligne 1 et répéter cette action pour les ligne suivante.

J'aurai souhaiter pouvoir sélectionner l'ensemble de mon tableaux et appuyer une seule fois sur mon bouton et que ça me génère l'ensemble des second tableaux.

Je vous joins mon fichier.

J'espère que j'ai été clairet que vous pourrez m'aider.

Merci par avance :)

Bonjour
Il faut initialiser une boucle du genre

Code:

1
2
3
4
5
6
7
8
Sub Macro7()
Dim cell As Range
For Each cell In Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
 
votre code
 
Next cell
end sub

Tous le reste du code devrait ressembler plutôt a ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
    cell.Offset(27, 0) = "Souhaite une étude personnalisée"
    cell.Offset(2, 0) = "Nom"
    cell.Offset(2, 0) = "Prenom"
    cell.Offset(2, 0) = "Email"
    cell.Offset(2, 0) = "Tel"
    cell.Offset(2, 0) = "CP"
    cell.Offset(2, 0) = "Imposition"
    cell.Offset(2, 0) = "Age"
    cell.Offset(2, 0) = "Source"
    cell.Offset(0, 1) = "Needocs"
    cell.Offset(-43, 0).Copy cell.Offset(29, 0).Range("A1")
    cell.Offset(-29, 1).Copy cell.Offset(31, -1).Range("A1")

Comme vous le voyer, il y a un sacré nettoyage a faire

12/11/2014, 13h49
nonodudu77

Bonjour,

Merci pour votre retour.

J'ai fait un peu de nettoyage mais je rencontre un problème. Lorsque je lance la macro, j'ai erreur d'execution 1004.

Je ne comprend pas mon erreur.

~~Je vous joints mon fichier.~~
Fichier joint dans vos discussions

Merci par avance pour votre aide.
12/11/2014, 14h07
SfJ5Rpw8

Bonjour,

sur qu'elle ligne l'erreur ? montre-nous le morceau de code concerné entre balises : [CODE][/CODE]

Bonjour,

Il s'agit de cette partie de code

Code:

cell.Offset(-43, 0).Copy cell.Offset(29, 0).Range("A1")

Mon code au complet est le suivant

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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
Sub Macro7()
Dim cell As Range
For Each cell In Range("a1:a12" & Cells(Rows.Count, 1).End(xlUp).Row)
'
' Macro7 Macro
'
 
'
    ActiveCell.Offset(27, 0) = "Souhaite une étude personnalisée"
    ActiveCell.Offset(2, 0) = "Nom"
    ActiveCell.Offset(2, 0) = "Prenom"
    ActiveCell.Offset(2, 0) = "Email"
    ActiveCell.Offset(2, 0) = "Tel"
    ActiveCell.Offset(2, 0) = "CP"
    ActiveCell.Offset(2, 0) = "Imposition"
    ActiveCell.Offset(2, 0) = "Age"
    ActiveCell.Offset(2, 0) = "Source"
    ActiveCell.Offset(0, 1) = "Needocs"
    cell.Offset(-43, 0).Copy cell.Offset(29, 0).Range("A1")
    cell.Offset(-29, 1).Copy cell.Offset(31, -1).Range("A1")
    cell.Offset(-31, 2).Copy cell.Offset(33, -2).Range("A1")
    cell.Offset(-31, 2).Copy cell.Offset(33, -2).Range("A1")
    cell.Offset(-33, 3).Copy cell.Offset(35, -3).Range("A1")
    cell.Offset(-35, 4).Copy cell.Offset(37, -4).Range("A1")
    cell.Offset(-37, 6).Copy cell.Offset(41, -6).Range("A1")
 
 
    ActiveWindow.SmallScroll Down:=-27
    ActiveCell.Offset(-41, 8).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=12
    ActiveCell.Offset(39, -8).Range("A1").Select
    ActiveSheet.Paste
 
    ActiveCell.Offset(-12, -1).Range("A1:B17").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveWindow.SmallScroll Down:=-3
    ActiveCell.Offset(-4, 0).Rows("1:21").EntireRow.Select
    ActiveCell.Offset(16, 0).Range("A1").Activate
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.Offset(-17, 0).Range("A1").Select
    ActiveWindow.SmallScroll Down:=-27
 
Next cell
End Sub

12/11/2014, 14h29
SfJ5Rpw8

Travailler avec ActiveCell et source d'ennui....

abuser de la propriété offset rend difficile la compréhension du code ...

vérifie que tu ne sort pas des limite de ta feuille , affiche par exemple l'adresse de cells ... dans fenêtre visualisation variable en mode débeugage... ou par un msgbox :

Code:

msgbox cell.address

... et voit si en y appliquant ton offset ( -43) tu ne te retrouve pas en dehors des limites de la feuille...
12/11/2014, 14h39
nonodudu77

Bonjour bbil,

Je suis novice et je suis un peu perdu concernant la manip que tu m'a conseillé d’exécuter.