Comment faire une boucle pour copier des données après des cellules vides dans une colonne et les coller dans la dernière colonne vide?

Essayez ceci, qui utilise SpecialCells pour extraire des blocs de cellules (ou de zones). Il suppose que les cellules ne contiennent pas de formules, donc si ce n'est pas le cas, elles devront être modifiées.

Sub x()

Dim r As Long

For r = 2 To Columns(1).SpecialCells(xlCellTypeConstants).Areas.Count
    Columns(1).SpecialCells(xlCellTypeConstants).Areas(r).Copy
    Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next r

End Sub

Je pense que vous pourriez essayer:

Option Explicit

Sub Test()

    Dim i As Long, LastRow As Long, LastColumn As Long, StartCell As Long, EndCell As Long
    Dim rng As Range

    With ThisWorkbook.Worksheets("Sheet1")
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = LastRow To 1 Step -1
            If IsEmpty(.Range("A" & i).Value) Then

                EndCell = i + 1

                LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column

                Set rng = .Range("A" & StartCell & ":A" & EndCell)

                rng.Cut .Cells(1, LastColumn + 1)
            Else
                If i = LastRow Or IsEmpty(.Range("A" & i).Offset(1, 0).Value) Then
                    StartCell = i
                End If

            End If

        Next i

    End With

End Sub

Veuillez essayer ce code. C'est très flexible. Vous pouvez ajuster les quatre paramètres en son sommet aux exigences de votre environnement.

Sub CopyToColumns()
    ' 02 Jan 2019

    ' Change these parameters to fit your requirements:-
    Const WsName As String = "TestSheet"
    Const SourceClm As String = "A"
    Const FirstRow As Long = 2                      ' applicable to all columns
    Const FirstTargetClm As String = "D"

    Dim Ws As Worksheet
    Dim InArr As Variant
    Dim OutArr As Variant, i As Long
    Dim Rng As Range
    Dim C As Long
    Dim R As Long

    On Error Resume Next
    Set Ws = ActiveWorkbook.Worksheets(WsName)
    If Err Then Exit Sub                            ' exit if the sheet doesn't exist
    On Error GoTo 0

    With Ws
        InArr = Range(.Cells(FirstRow, SourceClm), .Cells(.Rows.Count, SourceClm).End(xlUp)).Value
    End With
    C = Columns(FirstTargetClm).Column

    For R = 1 To UBound(InArr)
        If InArr(R, 1) <> "" Then
            i = 0
            ReDim OutArr(1 To UBound(InArr))
            Do
                i = i + 1
                OutArr(i) = InArr(R, 1)
                R = R + 1
                If R > UBound(InArr) Then Exit Do
            Loop While InArr(R, 1) <> ""
            If i Then
                ReDim Preserve OutArr(i)
                Set Rng = Cells(FirstRow, C).Resize(i)
                Rng.Value = Application.Transpose(OutArr)
                C = C + 1
            End If
        End If
    Next R
End Sub