VBA-如果一列具有特定文本并将数据粘贴到特定单元格区域中，则将数据传输到另一个工作表

Question

我目前正在尝试过滤数据并将其粘贴到另一张工作表中，直到某个范围，但它仅发布最新的数据行。如何修复代码，以便选择带有代码字的所有行并将其粘贴到另一张纸中。

这是我的代码：

Private Sub CommandButton1_Click()

Dim lastrow As Long, i As Long
lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow
    If Sheets("sheet1").Cells(i, 1) = "pp" Then
        Sheets("sheet1").Range(Cells(i, 2), Cells(i, 5)).Copy 
        ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A11:A22")
    End If
Next

End Sub

Answer 1

我认为这就是您想要的。

Private Sub CommandButton1_Click()

Dim ws1 as Worksheet: Set ws1 = Thisworkbook.Sheets("Sheet1")
Dim ws2 as Worksheet: Set ws2 = Thisworkbook.Sheets("Sheet5")

Dim LRow1 As Long, LRow2 as Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row

For i = 2 To lastrow
    If ws1.Cells(i, 1) = "pp" Then
        ws1.Range(Cells(i, 1), Cells(i, 5)).Copy 
        ws2.Range("A" & LRow + 1).PasteSpecial xlPasteValues
    End If
Next

End Sub

---

这是一种更有效的方法，它使用For Each循环和Copy/Paste的一个实例，而不是为每个匹配的单元重复1次迭代。

Option Explicit

Sub Copy()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim TargetRange As Range, TargetCell As Range, CopyRange As Range

Set TargetRange = ws1.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)

For Each TargetCell In TargetRange
    If TargetCell = "pp" Then
        If CopyRange Is Nothing Then
            Set CopyRange = TargetCell.Resize(1, 4)
        Else
            Set CopyRange = Union(CopyRange, TargetCell.Resize(1, 4))
        End If
    End If
Next TargetCell

CopyRange.Copy
ws2.Range("A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValuesAndNumberFormats

End Sub

---

另一种方法是为目标值pp应用过滤器，然后复制/粘贴可见单元格。