Как зациклить, чтобы скопировать данные после пустых ячеек в столбце и вставить его в последний пустой столбец?

Question

Мне нужно скопировать блок данных в столбце A (который находится между пробелами) и вставить его в последний пустой столбец.Пример: у меня есть данные в диапазоне A1: A18 и пустая ячейка, и снова данные в A20: A37 и 2 пустых ячейки, и снова данные в A40: A57 и так далее.Мне нужно скопировать эти данные и вставить в столбцы B, C, D ....

Шаблон пробелов не является равномерным.

Снимок экрана файла Excel

Я провел небольшое исследование в Интернете и создал код для вставки вручную выбранных данных в столбце A в последний пустой столбец.Но список слишком длинный, и я хочу автоматизировать процесс.

Я попробовал этот код, чтобы найти пробелы и скопировать данные.Он находит последнюю пустую строку и копирует все данные, выдавая ошибку.

Sub Pasting_Data_to_last_column()
Dim xWs As Worksheet
Dim rng As Range
Dim lastCol As Long

Sheets("Input").Activate
Application.ScreenUpdating = False

'finds the number of the last column
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Range("A1", Cells(Rows.Count, 1).End(xlUp)).Copy

'paste the copied value to last empty column
Cells(1, lastCol + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub

Я считаю, что эту проблему можно решить с помощью цикла, но я понятия не имею об этом, так как я новичок вVBA.

Answer 1

Я думаю, вы могли бы попробовать:

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

Answer 2

Пожалуйста, попробуйте этот код.Это очень гибкий.Вы можете настроить четыре параметра в его верхней части в соответствии с требованиями вашей среды.

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

Answer 3

Попробуйте это, используя SpecialCells для извлечения блоков ячеек (или областей). Предполагается, что ячейки не содержат формул, поэтому, если это не так, потребуется изменить.

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