Mettre plusieurs colonnes les unes à la suite des autres

Le 25/08/2016 à 15:37

Bonjour à tous,

J'ai un petit souci de copier coller automatique, en fait je souhaiterai mettre à la suite des colonnes dans une autre feuille à l'aide d'une macro et d'un bouton.

Le code ci-dessous permet bien de mettre à la suite des données de plusieurs colonnes sur une même colonne mais pour mon cas, ce sont 3 colonnes que je dois mettre les unes en dessous des autres...

Savez vous si je peux adapter ce code à mon cas?

Sub Transfert()
Range("I1:I65536").ClearContents
ligne = 1
For n = 1 To 5
  For m = 1 To Cells(65536, n).End(xlUp).Row
    If Cells(m, n) <> 0 Then
      Cells(ligne, 9) = Cells(m, n)
      ligne = ligne + 1
    End If
  Next m
Next n
End Sub

Merci!

142test.xlsm (19.25 Ko)
Le 25/08/2016 à 16:38

Bonsoir,

Voir la PJ

431copie-de-test.xlsm (25.48 Ko)
Le 25/08/2016 à 17:05

Bonjour,

Une proposition à étudier.

Cdlt.

146test-2.xlsm (31.51 Ko)
Option Explicit

Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsSource As Worksheet, wsCible As Worksheet
Dim lastCol As Long, lRow As Long, I As Long

    Application.ScreenUpdating = False

    Set wb = ActiveWorkbook
    Set wsSource = wb.Worksheets("données")
    Set wsCible = wb.Worksheets("Synthèse")

    With wsCible
        .Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    End With

    lRow = 2

    With wsSource
        lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        For I = 1 To lastCol Step 4
            .Cells(2, I).CurrentRegion.Offset(1, 0).Copy Destination:=wsCible.Cells(lRow, 1)
            lRow = wsCible.Cells(.Rows.Count, 1).End(xlUp).Row + 1
        Next I
    End With

    Set wsCible = Nothing: Set wsSource = Nothing
    Set wb = Nothing

End Sub
Le 26/08/2016 à 09:21

Bonjour,

Merci à vous 2 ça fonctionne super! mais où est ce que je modifie le code si dans mon fichier je n'ai plus de colonnes vides entre les différentes colonnes de données? Est ce qu'il faut tout réadapter où bien faut il juste modifier quelque chose dans le code?

Merci encore

Le 26/08/2016 à 10:36

Re,

As-tu testé avec d'autres colonnes ? Il me semble bien que j'ai ajouté pour le test des colonnes.

Le 26/08/2016 à 11:45

Bonjour,

Une mise à jour.

Cdlt.

195test-2.xlsm (29.66 Ko)
Option Explicit

Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsSource As Worksheet, wsCible As Worksheet
Dim lastCol As Long, lastRow As Long, lRow As Long, I As Long

    Application.ScreenUpdating = False

    Set wb = ActiveWorkbook
    Set wsSource = wb.Worksheets("données")
    Set wsCible = wb.Worksheets("Synthèse")

    With wsCible
        .Cells(1).CurrentRegion.Offset(1, 0).ClearContents
    End With

    lRow = 2

    With wsSource
        lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        For I = 1 To lastCol Step 3
            lastRow = .Cells(.Rows.Count, I).End(xlUp).Row
            .Cells(2, I).Offset(1, 0).Resize(lastRow - 2, 3).Copy _
                    Destination:=wsCible.Cells(lRow, 1)
            lRow = wsCible.Cells(.Rows.Count, 1).End(xlUp).Row + 1
        Next I
    End With

    Set wsCible = Nothing: Set wsSource = Nothing
    Set wb = Nothing

End Sub
Le 26/08/2016 à 14:26

Re,

Merci à vous deux, vos solutions fonctionnent dans mes différents cas. Merci beaucoup. je peux clôturer!!

Bye!

Le 04/03/2018 à 12:53

Bonjour,

Désolé de déterrer ce vieux message. Mais j'ai quasi le mème problème mais uniquement pour 2 colonnes (et non pas 3 ou 4 comme demandé) que je dois mettre les unes en dessous des autres.

Debut:

ColA ColB ColC ColD

1234 123 14524 1224

Resultat souhaité:

ColA ColB

1234 123

14524 1224

J'ai en fait 170 colonnes et 470 lignes.

J'ai essayé de triturer plusieurs fois les réponses apportées mais je reste bloqué ! ;(

Code proposé pour 3 (ou 4 en fait) colonnes :

Sub copierColler()
    Dim derLigSource As Integer, derLigDest As Integer, derCol As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    Set wsSource = Sheets("données")
    Set wsDest = Sheets("copie")
    wsDest.Range("A:C").EntireColumn.Delete
    wsSource.Activate
    derCol = wsSource.Cells(2, Columns.Count).End(xlToLeft).Column
    For i = 1 To derCol - 2 Step 4
        derLigDest = wsDest.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
        derLigSource = wsSource.Cells(Columns(i).Cells.Count, i).End(xlUp).Row
        wsSource.Range(Cells(2, i), Cells(derLigSource, i + 2)).Copy Destination:=wsDest.Cells(derLigDest + 1, 1)
    Next i
    wsDest.Activate
    wsDest.Rows(1).EntireRow.Delete
    Application.CutCopyMode = False
End Sub

Mon meilleur essai mais apparemment j'ai un dépassment de capacité ou lors d'un essai j'ai bien eu 2 colonnes mais résultat n'est pas complet :

Sub copierColler2Col()
    Dim derLigSource As Integer, derLigDest As Integer, derCol As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    Set wsSource = Sheets("données")
    Set wsDest = Sheets("copie")
    wsDest.Range("A:B").EntireColumn.Delete
    wsSource.Activate
    derCol = wsSource.Cells(2, Columns.Count).End(xlToLeft).Column
    For I = 1 To derCol - 1 Step 2
        derLigDest = wsDest.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
        derLigSource = wsSource.Cells(Columns(I).Cells.Count, I).End(xlUp).Row
        wsSource.Range(Cells(1, I), Cells(derLigSource, I + 1)).Copy Destination:=wsDest.Cells(derLigDest + 1, 1)
    Next I
    wsDest.Activate
    wsDest.Rows(1).EntireRow.Delete
    Application.CutCopyMode = False
End Sub

Cf. Fichier joint

Merci d'avance

44regrouper-toutes-les-colonnes-sous-2-colonnes.xlsm (16.35 Ko)
Le 05/03/2018 à 10:49

Bonjour,

Je déterre également le sujet. Je souhaiterai juste savoir s'il est possible de mettre plusieurs colonnes qui ne se suivent pas à la suite des autres.

Par exemple, dans le fichier joint, je voudrais mettre à la suite les colonne B, D et E.

J'ai essayé de le faire en bidouillant le dossier de Raja mais je n'y arrive pas :/

Merci d'avance !!

40essai-copie.xlsm (24.07 Ko)
Le 05/03/2018 à 11:16

Bonjour,

Vous avez la possibilité de joindre Raja!...

Cdlt

Le 18/03/2018 à 19:05

Bonsoir, Salut Jean-Eric,

Essaye comme ça :

Sub copierColler()
    Dim derLigSource As Integer, derLigDest As Integer, derCol As Integer
    Dim wsSource As Worksheet, wsDest As Worksheet
    Set wsSource = Sheets("données")
    Set wsDest = Sheets("Feuil1")
    wsDest.Range("A:C").EntireColumn.Delete
    wsSource.Activate
    derCol = wsSource.Cells(2, Columns.Count).End(xlToLeft).Column
    For i = 1 To derCol
        Select Case i
            Case 2, 4, 5
                derLigDest = wsDest.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
                derLigSource = wsSource.Cells(Columns(i).Cells.Count, i).End(xlUp).Row
                wsSource.Range(Cells(2, i), Cells(derLigSource, i)).Copy Destination:=wsDest.Cells(derLigDest + 1, 1)
        End Select
    Next i
    wsDest.Activate
    wsDest.Rows(1).EntireRow.Delete
    Application.CutCopyMode = False
End Sub
Rechercher des sujets similaires à "mettre colonnes suite"