使用vba将多个行复制到另一个工作表中的单个列中

Question

我有各种各样的活动的这个巨大的日期，看起来像这样。

我需要像这样的输出。  

我尝试使用这个下面的宏。

Sub lrow()
 Dim lcol As Long, rw As Long, j As Long, rc As Range
 j = 1
      For rw = 2 to Cells(Rows.Count, "A").End(xlUp).Row
      For lcol = 2 to Cells(rw, Columns.Count).End(xlToLeft).Column
        set rc = Cells(rw, lcol)
          If IsDate(rc.Value) Then
           With Sheet2
             Range(j, 2) = rc.Value
             j = j + 1
           End With
          End If
      Next lcol
      Next rw
  End Sub

我需要有关此代码的帮助。提前谢谢

Answer 1

您可以执行蛇形转移：

Sub Serpentine()
   Dim N As Long, i As Long, K As Long, j As Long
   Dim sh1 As Worksheet, sh2 As Worksheet
   K = 1
   Set sh1 = Sheets("Sheet1")
   Set sh2 = Sheets("Sheet2")
   N = sh1.Cells(Rows.Count, "A").End(xlUp).Row

   For i = 1 To N
      For j = 1 To Columns.Count
         If sh1.Cells(i, j) <> "" Then
            sh2.Cells(K, 1).Value = sh1.Cells(i, j).Value
            K = K + 1
         Else
            Exit For
         End If
      Next j
   Next i
End Sub

例如在 Sheet1 ：

中

将在 Sheet2 中生成：

Answer 2

如果您没有告诉我们问题是什么，那么很难找到解决方案，但这是我的抨击。不需要双嵌套循环;只需遍历所有输入单元格，直到找到空单元格，然后跳转到下一行的开头：

Public Sub Test()
    Dim rng As Range
    Set rng = Worksheets(1).Cells(1, 1)
    While rng.Column > 1 Or Not IsEmpty(rng)
        Debug.Print rng.Value
        Set rng = rng.Offset(0, 1)
        If IsEmpty(rng) Then Set rng = ws.Cells(rng.Row + 1, 1)
    Wend
End Sub

当循环遇到第一列中的空单元格时，循环停止。您会注意到我没有费心将日期写入第二张工作表，但这很简单。

Answer 3

此代码有效地从第一张纸张中取出所有日期并将其粘贴在第2页的A栏中：

Sub lrow()

j As Long, rc As Range

j = 1

For Each rc In Sheets(1).Range("A1", Sheets(1).Cells.SpecialCells(xlCellTypeLastCell))
    If IsDate(rc.Value) Then
        With Worksheets(2)
             .Cells(j, 1) = rc.Value
             j = j + 1
        End With
    End If
Next rc


End Sub

不知道这是不是你想要的。