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

我有这个看起来像这样的各种过程的活动的这个巨大的date。

我需要这样的输出。

我试图用这个波纹的macros。

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

如果你没有告诉我们这个问题是什么，那么很难想出一个解决scheme，但这里是我的捅刺。 不需要双嵌套循环; 只需遍历所有input单元格，直到到达空单元格，然后跳到下一行的开头：

 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 

循环遇到第一列中的空单元格时停止。 你会注意到我没有把date写到第二张工作表上，但这很简单。

Answer 3

此代码实际上是从第一张工作表中取出所有date，并将其粘贴到工作表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 

不知道这是你想要的。