Macro insertion de ligne+ copy/paste et récurrence opération

Version imprimable

Bonjour,

Je souhaite créer une macro qui permet d’insérer un certain nombre de lignes et de copier/coller automatique les réponses de la façon suivante:

Donnée existante: Question 1 | réponse 1 | réponse 2 | réponse 3 | réponse 4 | réponse 5

Macro à créer : Question 1 | réponse 1
Question 1 | réponse 2
Question 1 | réponse 3
Question 1 | réponse 4
Question 1 | réponse 5

Cette opération doit se faire que pour certaines questions à intervalles réguliers et non sur la totalité.
En terme de ligne excel par exemple : Ligne 5 - ligne 15 - ligne 25 - ligne 35

Voici ma macro:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub Insertionsligne() Application.ScreenUpdating = False For i% = 56 To 60 Step 5 Rows(i & ":" & i + 3).Insert shift:=xlDown Range("B" & i - 1 & ":" & "C" & i - 1).Copy Range("B" & i).Activate ActiveSheet.Paste Range("B" & i - 1 & ":" & "D" & i - 1).Copy Range("B" & i + 1).Activate ActiveSheet.Paste Range("B" & i - 1 & ":" & "E" & i - 1).Copy Range("B" & i + 2).Activate ActiveSheet.Paste Range("B" & i - 1 & ":" & "F" & i - 1).Copy Range("B" & i + 3).Activate ActiveSheet.Paste Next End Sub
Le résultat me donne ça:

Donnée existante: Question 1 | réponse 1 | réponse 2 | réponse 3 | réponse 4 | réponse 5

Macro réalisée : Question 1 | réponse 1
Question 1 | réponse 1 | réponse 2
Question 1 | réponse 1 | réponse 2 | réponse 3
Question 1 | réponse 1 | réponse 2 | réponse 3 | réponse 4
Question 1 | réponse 1 | réponse 2 | réponse 3 | réponse | réponse 5

De plus, je ne sais absolument pas comment créer une récurrence sur cette opération, comme indiqué précédemment.

Merci par avance pour vos conseils.

Bonjour,

C'est ce résultat que tu cherche à obtenir ? Test pour voir :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Sub Insertionsligne()
 
    Dim I As Integer
 
    'de 56 à 60 en pas de 5, la boucle ne sert à rien !
    For I = 56 To 60 Step 5
 
        'insersion des lignes
        Rows(I + 1 & ":" & I + 4).Insert xlDown
 
        'copie de la cellule B sur les cellules des lignes insérées
        Range("B" & I).AutoFill Range("B" & I & ":B" & I + 4), 1
 
        'déplacement des valeurs
        Range("D" & I).Cut Destination:=Range("C" & I + 1)
        Range("E" & I).Cut Destination:=Range("C" & I + 2)
        Range("F" & I).Cut Destination:=Range("C" & I + 3)
        Range("G" & I).Cut Destination:=Range("C" & I + 4)
 
    Next I
 
End Sub

Hervé.

04/06/2014, 17h02
jullianm

Aide complémentaire

Merci Hervé, le code fonctionne et j'ai enlevé la boucle. C'est impeccable.

En revanche, je souhaiterais appliquer cette macro à plusieurs lignes bien spécifiques au sein de mon fichier.
Mon objectif serait de modifier la macro et d'ajouter des lignes qui permettraient d'appliquer cette macro seulement sur les lignes contenant des données précises.
En résumé, Appliquer la macro aux lignes contenant tel ou tel mot.v
Une autre possibilité : que toutes les lignes a partir de la colonne C qui ne sont pas vides soient traitées selon le principe de la macro que vous m'avez donné

Une idée?

Je ne sais pas si c'est bien clair,

Je vous remercie pour votre aide,

Re,

Teste après avoir adapté les mots recherchés, le nom de la feuille et la plage dans 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
 
Sub Insertionsligne()
 
    Dim Cel As Range
    Dim Texte
    Dim I As Integer
    Dim J As Integer
 
    'stocke dans un tableau Variant les mots à rechercher, à adapter...
    Texte = Array("Mot1", "Mot2", "Mot3")
 
    'boucle sur le tableau
    For I = 0 To UBound(Texte)
 
        'la recherche est en correspondance exacte (xlWhole) et sur la colonne B de la feuille "Feuil1", à adapter...
        Set Cel = Worksheets("Feuil1").Columns("B:B").Find(Texte(I), , xlValues, xlWhole)
 
        If Not Cel Is Nothing Then
 
            J = Cel.Row
 
            'insersion des lignes
            Rows(J + 1 & ":" & J + 4).Insert xlDown
 
            'copie de la cellule B sur les cellules des lignes insérées
            Range("B" & J).AutoFill Range("B" & J & ":B" & J + 4), 1
 
            'déplacement des valeurs
            Range("D" & J).Cut Destination:=Range("C" & J + 1)
            Range("E" & J).Cut Destination:=Range("C" & J + 2)
            Range("F" & J).Cut Destination:=Range("C" & J + 3)
            Range("G" & J).Cut Destination:=Range("C" & J + 4)
 
        End If
 
    Next I
 
End Sub

Hervé.

Bonjour Hervé,

Merci pour votre aide, j'ai arrangé le code selon vos préconisations MAIS cela ne fonctionne pas correctement,
La macro ne s’opère pas à chaque fois qu'elle rencontre les mots clefs définis dans l'array. En gros, sur ma colonne A, chaque fois que les mots clefs définis sont rencontrés je souhaiterais que s'opère le code "insertions lignes+ copier coller" que vous m'avez montré précédemment.
Petite précision: si je mets qu'un seul mot clef, il le trouve bien et fait l'opération correctement, si j'en mets plusieurs (ce que je souhaite), c'est le bordel.
Précision n°2: On peut trouver plusieurs fois dans ma colonne le même mot clef.

Voici la macro:
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 Sub Insertionsligne() Dim Cel As Range Dim Texte Dim I As Integer Dim J As Integer 'stocke dans un tableau Variant les mots à rechercher, à adapter... trouver ces mots clefs --> Traiter ces lignes Texte = Array("Fabrication mécanique", "Surface", "Electromécanique", "Mécanique", "Electrique", "Imagerie RX", "Equipements", "Informatique", "Marquage*-*Etiquetage", "Outillage", "Bureautique", "Sous*traitance", "Prestataire*de*Services") ' 'boucle sur le tableau For I = 0 To UBound(Texte) 'la recherche est en correspondance exacte (xlWhole) et sur la colonne B de la feuille "Feuil1", à adapter... Set Cel = Worksheets("Feuil2").Columns("A:A").Find(Texte(I), , xlValues, xlWhole) If Not Cel Is Nothing Then I = Cel.Row ' j'ai remplacé par I au lieu de J' 'insersion des lignes Rows(I + 1 & ":" & I + 5).Insert xlDown 'copie de la cellule B sur les cellules des lignes insérées Range("A" & I).AutoFill Range("A" & I & ":A" & I + 5), 1 'déplacement des valeurs Range("C" & I).Cut Destination:=Range("B" & I + 1) Range("D" & I).Cut Destination:=Range("B" & I + 2) Range("E" & I).Cut Destination:=Range("B" & I + 3) Range("F" & I).Cut Destination:=Range("B" & I + 4) Range("G" & I).Cut Destination:=Range("B" & I + 5) End If Next I End Sub
Merci pour votre aide,

Bonjour,

Citation:

Petite précision: si je mets qu'un seul mot clef, il le trouve bien et fait l'opération correctement, si j'en mets plusieurs (ce que je souhaite), c'est le bordel.

Le fait de rajouter les mêmes mots dans les lignes insérées (AutoFill) fait qu'on ne peut pas utiliser la fonction Find car ça va boucler sans s'arrêter :-( Il faut passer par une moulinette. Teste ce qui suit :

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
 
Sub Insertionsligne()
 
    Dim Plage As Range
    Dim Texte
    Dim I As Integer
    Dim J As Long
    Dim Adr As String
 
    'stocke dans un tableau Variant les mots à rechercher, à adapter...
    Texte = Array("Fabrication mécanique", "Surface", "Electromécanique", _
                  "Mécanique", "Electrique", "Imagerie RX", "Equipements", _
                  "Informatique", "Marquage*-*Etiquetage", "Outillage", _
                  "Bureautique", "Sous*traitance", "Prestataire*de*Services")
 
    'boucle sur le tableau
    For I = 0 To UBound(Texte)
 
        'défini la plage à chaque fois
        With Worksheets("Feuil1")
 
            Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
        End With
 
        'mouline sur la plage à la recherche des mots clés en commençant par la fin
        For J = Plage.Count To 1 Step -1
 
            If Texte(I) = Plage(J) Then
 
                'insersion des lignes
                Rows(J + 1 & ":" & J + 4).Insert xlDown
 
                'copie de la cellule B sur les cellules des lignes insérées
                Range("A" & J).AutoFill Range("A" & J & ":A" & J + 5), 1
 
                'déplacement des valeurs
                Range("C" & I).Cut Destination:=Range("B" & I + 1)
                Range("D" & I).Cut Destination:=Range("B" & I + 2)
                Range("E" & I).Cut Destination:=Range("B" & I + 3)
                Range("F" & I).Cut Destination:=Range("B" & I + 4)
                Range("G" & I).Cut Destination:=Range("B" & I + 5)
 
            End If
 
        Next J
 
    Next I
 
End Sub

Hervé.

Bonjour, merci pour votre réponse. J'ai essayé cette macro, j'ai modifié la plage "With worksheets (Feuil2)" et une erreur apparait(lligne en gras) " range global de l'objet a échoué". Je ne comprends pas... Mes mots clés se trouvent bien sur la colonne A de feuil2.

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
Sub Insertionsligne()
 
    Dim Plage As Range
    Dim Texte
    Dim I As Integer
    Dim J As Long
    Dim Adr As String
 
    'stocke dans un tableau Variant les mots à rechercher, à adapter...
    Texte = Array("Fabrication mécanique", "Surface", "Electromécanique", _
                  "Mécanique", "Electrique", "Imagerie RX", "Equipements", _
                  "Informatique", "Marquage*-*Etiquetage", "Outillage", _
                  "Bureautique", "Sous*traitance", "Prestataire*de*Services")
 
    'boucle sur le tableau
    For I = 0 To UBound(Texte)
 
        'défini la plage à chaque fois
        With Worksheets("Feuil2")
 
            Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
        End With
 
        'mouline sur la plage à la recherche des mots clés en commençant par la fin
        For J = Plage.Count To 1 Step -1
 
            If Texte(I) = Plage(J) Then
 
                'insersion des lignes
                Rows(J + 1 & ":" & J + 4).Insert xlDown
 
                'copie de la cellule B sur les cellules des lignes insérées
                Range("A" & J).AutoFill Range("A" & J & ":A" & J + 5), 1
 
                'déplacement des valeurs
                Range("C" & I).Cut Destination:=Range("B" & I + 1)
                Range("D" & I).Cut Destination:=Range("B" & I + 2)
                Range("E" & I).Cut Destination:=Range("B" & I + 3)
                Range("F" & I).Cut Destination:=Range("B" & I + 4)
                Range("G" & I).Cut Destination:=Range("B" & I + 5)
 
            End If
 
        Next J
 
    Next I
 
End Sub