使用 VBA 在第一个块下剪切和粘贴数据块答案

【问题标题】：Cut and Paste Blocks of Data underneath first block using VBA使用 VBA 在第一个块下剪切和粘贴数据块
【发布时间】：2019-10-29 09:01:43
【问题描述】：

我一直在尝试想出/找到一个 VBA 代码，它可以在我的第一个块下复制数据块。每个块是 19 列，后跟一个空格。每个块的行数可以变化。

请看下面的截图：

因此，我希望我的所有数据在第一列A:S 中都是连续的。非常感谢任何帮助。

我在网上找到了以下代码，但这只是将所有内容粘贴到第一列

Sub Column()

Dim iLastcol As Long
Dim iLastRow As Long
Dim jLastrow As Long
Dim ColNdx As Long
Dim ws As Worksheet
Dim myRng As Range
Dim ExcludeBlanks As Boolean
Dim mycell As Range

ExcludeBlanks = (MsgBox("Exclude Blanks", vbYesNo) = vbYes)
Set ws = ActiveSheet
iLastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
On Error Resume Next

Application.DisplayAlerts = False
Worksheets("Alldata").Delete
Application.DisplayAlerts = True

Sheets.Add.Name = "Alldata"

For ColNdx = 1 To iLastcol

iLastRow = ws.Cells(ws.Rows.Count, ColNdx).End(xlUp).Row

Set myRng = ws.Range(ws.Cells(1, ColNdx), _
                   ws.Cells(iLastRow, ColNdx))

If ExcludeBlanks Then
  For Each mycell In myRng
     If mycell.Value <> "" Then
        jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
                   .End(xlUp).Row
        mycell.Copy
        Sheets("Alldata").Cells(jLastrow + 1, 1) _
           .PasteSpecial xlPasteValues
      End If
    Next mycell
      Else
       myRng.Copy
          jLastrow = Sheets("Alldata").Cells(Rows.Count, 1) _
            .End(xlUp).Row
      mycell.Copy
      Sheets("Alldata").Cells(jLastrow + 1, 1) _
     .PasteSpecial xlPasteValues
    End If
   Next

   Sheets("Alldata").Rows("1:1").EntireRow.Delete

   ws.Activate
 End Sub

【问题讨论】：

所以，你知道每个数据块的起始单元格。
我的意思是，所有块都有相同数量的列

标签： excel vba

【解决方案1】：

基本方法：

Sub Tester()

    Dim c As Range, addr

    Set c = ActiveSheet.Range("T1")

    Do
        Set c = c.End(xlToRight)
        If c.Column = Columns.Count Then Exit Do
        addr = c.Address 'strire the address since Cut will move c
        c.CurrentRegion.Cut c.Parent.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Set c = ActiveSheet.Range(addr) '<< reset c
    Loop


 End Sub

【讨论】：

【解决方案2】：

这比@TimWilliams 更基本一点

With ThisWorkbook.Sheets("Alldata")

Dim lRow As Long, lCol As Long, cpyrng As Range

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

    For i = 21 To lCol Step 20
        If .Cells(1, i).Value <> "" And .Cells(1, i).Offset(, -1).Value = "" Then

            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row

            Set cpyrng = .Cells(1, i).CurrentRegion

            cpyrng.Cut
            Sheets("Sheet2").Cells(lRow, 1).Offset(2).Insert Shift:=xlDown
        End If
    Next i
End With

【讨论】：