Macro pour inserer des lignes verticalements et copier des cellu

Résolu/Fermé

bubu635863 Messages postés 12 Date d'inscription vendredi 4 octobre 2013 Statut Membre Dernière intervention 12 janvier 2016 - 4 oct. 2013 à 13:12
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 - 4 oct. 2013 à 16:09

Bonjour,

Voilà mon problème, j'ai un tableau Excel avec des données en colonnes et en lignes
je souhaiterais insérer 6 lignes entre chaque code de la colonne B ; que la cellule c2 vienne en b2, que la cellule d2 vienne en b4; que la cellule f2 vienne en b5 ; puis que la cellule b3 vienne en b7 et on recommence...

Mon tableau fait 6500 lignes... je sais que copier collage spécial / transposé le fait mais c'est un peu long :(

Je joins un petit fichier avec un exemple de mon tableau de base "onglet stliv" et ce que je souhaiterais en feuil1.

Merci pour votre aide.

Tableau de départ :

A B C D E F
1 Reference Qte cmd Code c1 Adresse PCX
2 Y001 48053026 1 11400 H1016 228
3 48092443 4 126 TG14 2.52
4 48070743 1 8000 H2024 160
5 68280800 1 F1008
6 66344012 2 C1009
7 63613501 1 B4008
8 Y002 68474294 3 A3003
9 65336600 1 A3003
10 61450991 1 A3003

Tableau d'arrivée :

A B
1 Y001 48053026
2 1
3
4 11400
5 228
6
7 48092443
8 4
9
10 126
11 2.52
12
13 48070743
14 1
15
16 8000
17 160
18
19 68280800
20 1
21
22
23
24
25 66344012
26 2
27
28
29
30
31 63613501
32 1
33
34
35
36
37 Y002 68474294
38 3
39
40
41
42
43 65336600
44 1
45
46

A voir également:

Macro pour inserer des lignes verticalements et copier des cellu
Insérer signature word - Guide
Insérer liste déroulante excel - Guide
Copier une vidéo youtube - Guide
Insérer table des matières word - Guide
Macro word - Guide

3 réponses

Réponse 1 / 3

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
4 oct. 2013 à 14:34

Bonjour,

et il est où le "petit fichier" ?

merci de mettre environ 1500 lignes

pour joindre une pièce
mettre le classeur sans données confidentielles en pièce jointe sur
https://www.cjoint.com/
puis copier l'adresse du lien et la coller dans le message de réponse

bubu635863 Messages postés 12 Date d'inscription vendredi 4 octobre 2013 Statut Membre Dernière intervention 12 janvier 2016
4 oct. 2013 à 15:10

https://www.cjoint.com/?0JepjInhbSa

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
4 oct. 2013 à 16:01

Merci, mais je t'avais demandé environ 1500 lignes pour tester la rapidité d'exécution du réaménagement....

Bubu635863 > michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023
4 oct. 2013 à 16:05

Merci Michel m, via55 a pleinement répondu a ma question merci encore pour ton dévouement
Cordialement

Réponse 2 / 3

via55 Messages postés 14402 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 18 avril 2024 2 702
4 oct. 2013 à 14:43

Bonjour

Macro possible pour transposer de Feuil1 en Feuil2 selon tes critères

Sub transposition()
un = "Feuil1"
deu = "Feuil2"
der = InputBox("N° de la dernière ligne à transposer ?")
lg = 2 'donc commencera à copier à partir de la ligne 2
For n = lg To der
a = a + 1
Sheets(deu).Cells(a, 1) = a
Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 2).Value
a = a + 1
Sheets(deu).Cells(a, 1) = a
Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 3).Value
a = a + 1
Sheets(deu).Cells(a, 1) = a
a = a + 1
Sheets(deu).Cells(a, 1) = a
Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 4).Value
a = a + 1
Sheets(deu).Cells(a, 1) = a
Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 6).Value
a = a + 1
Sheets(deu).Cells(a, 1) = a
Next

End Sub

Cdlmnt

Réponse 3 / 3

bubu635863 Messages postés 12 Date d'inscription vendredi 4 octobre 2013 Statut Membre Dernière intervention 12 janvier 2016
4 oct. 2013 à 15:16

Top, merci ta macro à l'air de marcher du feu de dieux.
Par contre dans cette dernière, en colonne A, j'ai le numéro de ligne qui apparait ce que je ne souhaitait pas forcément.
J'ai rajouter sur le post précédent de Michel_m un lien (merci michel_m pour l'explication comment poster un lien...) avec le fichier en question et la "présentation" finale recherchée sur la Feuil1

Cordialement,

via55 Messages postés 14402 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 18 avril 2024 2 702
4 oct. 2013 à 15:28

Si tu ne veux pas le n° de ligne tu supprimes dans la macro toutes les lignes
Sheets(deu).Cells(a, 1) = a
Cdlmnt

bubu635863 Messages postés 12 Date d'inscription vendredi 4 octobre 2013 Statut Membre Dernière intervention 12 janvier 2016
4 oct. 2013 à 15:37

re top,
merci mais sans vouloir t'ennuyer, je souhaiterais que dans la colonne A apparaisse le Y001 en face du N° de référence concerné...
C'est difficile à expliquer, je te joins le fichier, je pense que ce sera plus simple de visu.
onglet STLIV = fichier de départ
Feuil1 = fichier souhaité

Merci encore.

https://www.cjoint.com/?0JepjInhbSa

via55 Messages postés 14402 Date d'inscription mercredi 16 janvier 2013 Statut Membre Dernière intervention 18 avril 2024 2 702
4 oct. 2013 à 15:39

Au vu de ton fichier, modification pour la 1ere colonne + choix des feuilles

Sub transposition()

un = InputBox("Nom de la feuille à transposer ?")
deu = InputBox("Nom de la feuille où effectuer la transposition ?")
der = InputBox("N° de la dernière ligne à transposer ?")
lg = 2 'donc commencera à copier à partir de la ligne 2
For n = lg To der
a = a + 1
Sheets(deu).Cells(a, 1) = Sheets(un).Cells(n, 1).Value
Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 2).Value
a = a + 1

Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 3).Value
a = a + 1

a = a + 1

Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 4).Value
a = a + 1

Sheets(deu).Cells(a, 2).Value = Sheets(un).Cells(n, 6).Value
a = a + 1

Next

End Sub

bubu635863 Messages postés 12 Date d'inscription vendredi 4 octobre 2013 Statut Membre Dernière intervention 12 janvier 2016
4 oct. 2013 à 15:43

Merci, t'es un CHEF !!!! :-)

michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 3 303
4 oct. 2013 à 16:09

Excusez moi de présenter une solution mais...
Chiche! on fait un concours de rapidité sur 6500 lignes ?

Option Base 1
Sub reamenager()
Dim Derlig As Integer, Lig_in As Integer, T_in(), Pas As Byte
Dim T_out(), Lig As Byte
Dim Start As Single


'initialisations
Start = Timer
Application.ScreenUpdating = False
With Sheets("stliv")
     Derlig = .Columns("B").Find("*", , , , , xlPrevious).Row
     'mémorisation tableau initial
     T_in = .Range("A2:F" & Derlig).Value
End With

'réaménagement
Pas = 1
Lig = 1
For Lig_in = 1 To UBound(T_in)
     Pas = Pas + 6
     ReDim Preserve T_out(2, Pas)
          T_out(1, Lig) = T_in(Lig_in, 1)
          T_out(2, Lig) = T_in(Lig_in, 2)
          Lig = Lig + 1
          T_out(2, Lig) = T_in(Lig_in, 3)
          Lig = Lig + 2
          T_out(2, Lig) = T_in(Lig_in, 4)
          Lig = Lig + 2
          T_out(2, Lig) = T_in(Lig_in, 6)
          Lig = Lig + 1
Next
With Sheets(1)
     .Range("D1").Resize(Lig, 2) = Application.Transpose(T_out)
End With
Application.ScreenUpdating = True
MsgBox "réaménagement effectué en: " & Timer - Start & " .secondes"
End Sub

Discussions similaires

Dessiner avec son clavier et avec des lettres

Discussions similaires

Newsletters