Sub test() Dim rws As Long, rw As Long, i As Long Dim cel As Range rws = Sheet1.UsedRange.Rows.Count For i = 1 To rws If Cells(i, 1) <> "" And Val(Cells(i, 1)) > 0 Then Set cel = Cells(i, 1) Sheet1.Range(cel, cel.Offset(0, 1).End(xlDown)).Copy Destination:=Sheet2.Range("B65536").End(xlUp).Offset(2, -1) End If Next End Sub追问