该程序选择整行，如何将选择限制为A到M.

Question

Sub Test()

Dim Cell As Range

With Sheets(1)
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        If Cell.Value = "0" Then
             ' Copy>>Paste in 1-line (no need to use Select)
            .Rows(Cell.Row).Copy Destination:=Sheets(4).Rows(Cell.Row)
        End If
    Next Cell
End With

End Sub

Answer 1

尝试

Sub Test()

Dim Cell As Range

With Sheets(1)
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        If Cell.Value = "0" Then
             ' Copy>>Paste in 1-line (no need to use Select)
             Dim targetRow As Long
             targetRow = Cell.Row
            .Range("A" & targetRow & ":H" & targetRow).Copy Destination:=Sheets(4).Rows(Cell.Row)
        End If
    Next Cell
End With

End Sub

但是

因为这会产生一种奇怪的重复粘贴，你真的想要吗？注意我用currentCell替换了变量单元格以避免混淆

Option Explicit

Sub Test()

    Dim currentCell As Range

    With Sheets(1)

        For Each currentCell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)

            If currentCell.Value = "0" Then

                Dim targetRow As Long
                targetRow = currentCell.Row
                .Range("A" & targetRow & ":H" & targetRow).Copy Destination:=Sheets(4).Cells(currentCell.Row, 1)

            End If

        Next currentCell

    End With

End Sub

和

如@DisplayName所述，您在评论中提到了H列。如果你打算循环这个，那么改变：

For Each currentCell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)

对于

 For Each currentCell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)

Answer 2

以下是替换它的其他一些选项：

.Rows(Cell.Row).Copy 

使用以下任一方法：

1. Cell.Resize(1,13).Copy
2. Intersect(Cell.EntireRow, .Range("A:M")).Copy

或者您可以遍历行而不是特定的单元格：

Sub Test()
    Dim currentRow As Range
    With Sheets(1)
        ' loop column H untill last cell with value (not entire column)
        For Each currentRow In .Range("A1:M" & .Cells(.Rows.Count, "A").End(xlUp).Row).Rows
            If currentRow.Cells(1, 1).Value = "0" Then
                 ' Copy>>Paste in 1-line (no need to use Select)
                currentRow.Copy Destination:=Sheets(4).Rows(currentRow.Row)
            End If
        Next Cell
    End With
End Sub

Answer 3

使用

.Range("A:M").Rows(Cell.row).Copy Destination:=Sheets(4).Rows(Cell.row)

但您可能在错误的栏目中，因为您正在评论：

' loop column H until last cell with value (not entire column)

编码时

：

For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).row)

即。你在A列中循环！

所以你可能想要编码：

Sub Test()

    Dim cell As Range

    With Sheets(1)
        ' loop column H until last cell with value (not entire column)
        For Each cell In .Range("H1:H" & .Cells(.Rows.Count, "A").End(xlUp).row) ' loop through column H cells from row 1 down to last not empty row in column A
            If cell.Value = "0" Then .Range("A:M").Rows(cell.row).Copy Destination:=Sheets(4).Rows(cell.row)
        Next cell
    End With

End Sub

Answer 4

试

Sub Test()
  Dim Cell As Range

  With Sheets(1)
    ' loop column H untill last cell with value (not entire column)
    For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
      If Cell.Value = "0" Then
            ' Copy>>Paste in 1-line (no need to use Select)
        Sheets(4).Range("A:" & Cell.Row & ":M" & Cell.Row).Value = .Range("A:" & Cell.Row & ":M" & Cell.Row).Value
      End If
    Next Cell
  End With
End Sub