从两个单元格值之间复制数据，并使用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

代码中有很多不需要的事情。看看下面，看看你是否可以关注正在发生的事情：

Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub

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