如何循环复制列中空白单元格后的数据并将其粘贴到最后一个空列？

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

试试这个，它使用 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

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

我觉得你可以试试：

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