从两个单元格值之间复制数据，然后使用VBA（Excel）将复制的数据粘贴到新工作表的新列中

Question

我正在尝试从两个单元格值之间复制所有行，并将这些值粘贴到新工作表的新列中。假设我的数据在一个excel列中的结构如下：

x

1
2
3

y
x

4
5
6

y

所以我想复制123和456，分别粘贴到A和B列的新工作表中，如下所示：

  A   B
1 1   4
2 2   5
3 3   6

我正在使用的代码可以很好地复制数据，但只能将它们粘贴在彼此之间。每次循环运行时，是否可以修改以下代码以将复制的数据粘贴到新列中？

Private Sub CommandButton1_Click()

   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)


   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "x" Then
          startrow = rownum
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 1).Value = "y"
   endrow = rownum - 1
   rownum = rownum + 2

   Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy


   Sheets("Sheet2").Select
   ActiveSheet.Range("A1").Select
   ActiveSheet.Paste


   Next rownum
   End With

End Sub

谢谢。

Answer 1

该代码中有很多不需要做的事情。看看下面的内容，看看您是否可以了解正在发生的事情：

filter

Answer 2

您可以使用：

SpecialCells()对象的

• Range方法捕获“数值”值范围

Areas对象的

• Range属性可遍历每组“数字”范围

如下：

Sub CommandButton1_Click()
    With Worksheets("Sheet1")
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
            Dim area As Range
            For Each area In .Areas
                With Worksheets("Sheet2")
                    .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
                End With
            Next
        End With
    End With
    Worksheets("Sheet2").Columns(1).Delete
End Sub

---

要管理“ x”或“ x”与“ y”之间的任何格式（不仅是“数字”）的数据，然后使用

AutoFilter()对象的

• Range方法在“ x”或“ x”与“ ys”之间过滤数据“

SpecialCells()对象的

• Range方法捕获非空值范围

Areas对象的

• Range属性可遍历每组“选定”范围

如下：

Sub CommandButton1_Click()
    Dim area As Range

    With Worksheets("Sheet1")
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
            With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
                For Each area In .Areas
                    With Worksheets("Sheet2")
                        .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
                    End With
                Next

            End With
        End With
        .AutoFilterMode = False
    End With
    Worksheets("Sheet2").Columns(1).Delete
End Sub

Answer 3

已经提到了这种类型，但是自从我写了它之后，我还将使用范围区域来共享它。

这还假设布局在原始问题中是实际的，并且您正在尝试提取一组数字。

Sub Button1_Click()
    Dim sh As Worksheet, ws As Worksheet
    Dim RangeArea As Range

    Set sh = Sheets("Sheet1")
    Set ws = Sheets("Sheet2")

    For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas

        RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)

    Next RangeArea

End Sub