如果满足条件，只复制一列（需要调整我现有的代码）

下面的代码适用于复制整个行，我怎么做，所以我只复制第一列。

我尝试改变范围，没有成功？ 条件是在J中，唯一要复制的列应该是第一个。

Dim cell As Range Dim lastRow As Long, i As Long lastRow = Range("B" & Rows.Count).End(xlUp).Row i = 1 For Each cell In Sheets(1).Range("J1:J" & lastRow) If cell.Value = 1 Then cell.EntireRow.Copy Sheets(5).Cells(i, 1) i = i + 1 End If Next End Sub 

非常感谢！

Answer 1

只需将EntireRow切换到EntireColumn ，就是EntireColumn简单！ ;）

 Dim rCell As Range Dim lastRow As Long, i As Long lastRow = Range("B" & Rows.Count).End(xlUp).Row i = 1 For Each rCell In Sheets(1).Range("J1:J" & lastRow) If rcell.Value = 1 Then rcell.EntireColumn.Copy Sheets(5).Cells(1, i) i = i + 1 End If Next rCell 

Answer 2

尝试

 Dim cell As Range Dim lastRow As Long, i As Long lastRow = Range("B" & Rows.Count).End(xlUp).Row i = 1 For Each cell In Sheets(1).Range("J1:J" & lastRow) If cell.Value = 1 Then cells(cell.row,1).Copy Sheets(5).Cells(i, 1) i = i + 1 End If Next End Sub 

Answer 3

 Dim cell As Range Dim lastRow As Long, i As Long lastRow = Range("B" & Rows.Count).End(xlUp).Row i = 1 For Each cell In Sheets(1).Range("J1:J" & lastRow) If cell.Value = 1 Then cell.End(xlToLeft).Copy Sheets(5).Cells(i, 1) i = i + 1 End If Next End Sub