копировать только один столбец, если критерии выполнены (необходимо скорректировать мой существующий код)

Question

Этот код отлично подходит для копирования всей строки, как это сделать, поэтому я копирую только первый столбец.

Я пробовал диапазон изменения без успеха? Условие в 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, это так просто! ;)

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