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

Question

我有这个巨大的 Activity 各种过程的日期，看起来像这样。

我需要这样的输出。

我尝试使用这个波纹管宏。

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

如果您不告诉我们问题出在哪里，就很难找到解决方案，但这是我的尝试。不需要双嵌套循环；只需遍历所有输入单元格，直到到达一个空单元格，然后跳转到下一行的开头：

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 2

此代码有效地从第一个 sheet 中获取所有日期并将它们粘贴到 Sheet 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

不知道是不是你想要的。

Answer 3

您可以执行蛇形传输：

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 中生成：

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

Copy Multiple Rows into Single Column in another sheet using vba

excel

vba

multiple-columns