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
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
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 logiciel - Télécharger - Organisation
3 réponses
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
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
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
via55
Messages postés
14394
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
26 mars 2024
2 698
4 oct. 2013 à 14:43
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
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
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
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,
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
14394
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
26 mars 2024
2 698
4 oct. 2013 à 15:28
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
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
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
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
14394
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
26 mars 2024
2 698
4 oct. 2013 à 15:39
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
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
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
4 oct. 2013 à 16:09
Excusez moi de présenter une solution mais...
Chiche! on fait un concours de rapidité sur 6500 lignes ?
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
4 oct. 2013 à 15:10
4 oct. 2013 à 16:01
4 oct. 2013 à 16:05
Cordialement