在滿足條件的情況下將單元格復制到另一個工作表

Question

我需要遍歷一列，如果滿足條件則將單元格從一張紙復制到另一張紙。

我發現增量式的問題。在這種情況下，結果翻倍。

先感謝您。 KR

Sub copycell()

Dim iLastRow As Long
Dim i As Long
Dim erow As Long

erow = 1

iLastRow = Worksheets("Clientes").Cells(Rows.Count, "C").End(xlUp).Row
For i = 13 To iLastRow
    If Sheets("Clientes").Cells(i, 3) = "0" Then
        Worksheets("Ficheros").Range("B" & erow).End(xlUp).Offset(1) = Sheets("Clientes").Cells(i, 4)

        erow = erow + 1
    End If
Next i

End Sub

Answer 1

您可以使用AutoFilter實現結果，但是我的答案是嘗試使用For循環解析您的代碼。

修改后的代碼

Option Explicit

Sub copycell()

Dim iLastRow As Long
Dim i As Long
Dim erow As Long

' get first empty row in column B in "Ficheros" sheet
erow = Worksheets("Ficheros").Range("B" & Rows.Count).End(xlUp).Row + 1

With Worksheets("Clientes")
    iLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

    For i = 13 To iLastRow
        If .Cells(i, 3) = "0" Then
            Worksheets("Ficheros").Range("B" & erow) = .Cells(i, 4)

            erow = erow + 1
        End If
    Next i
End With

End Sub

Answer 2

為什么不使用自動過濾器來過濾列C，並且如果自動過濾器返回任何行，請將其復制到目標表中？

看看類似的東西對您有用...

Sub CopyCells()
Dim wsData As Worksheet, WsDest As Worksheet
Dim iLastRow As Long
Application.ScreenUpdating = False
Set wsData = Worksheets("Clientes")
Set WsDest = Worksheets("Ficheros")
iLastRow = wsData.Cells(Rows.Count, "C").End(xlUp).Row

wsData.AutoFilterMode = False

With wsData.Rows(12)
    .AutoFilter field:=3, Criteria1:="0"
    If wsData.Range("D12:D" & iLastRow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        wsData.Range("D13:D" & iLastRow).SpecialCells(xlCellTypeVisible).Copy
        WsDest.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
    End If
End With

wsData.AutoFilterMode = False

Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub