错误的数据正被复制到另一个表单中

我正在复制两列A和B的一些数据，基于B中是否有PRNA ，然后将A和B复制到“Sheet1”中。 现在我面临的问题是，它复制一切有PRNA但有时它复制Not available 。 这是代码：

  Dim Cell2 As Range, LastRow2 As Long Dim count As Integer LastRow2 = Cells(Rows.count, "B").End(xlUp).Row Set rng3 = Range("B2:B" & LastRow2) Set ws = Sheets("Sheet1") For Each Cell2 In rng3 If Cell2.Value = "PRNA" Then 'Range(Cells(rng3.Row, 1), Cells(rng3.Row, 2)).Copy 'Range("A1").Offset(count, 0).PasteSpecial Range(Cells(Cell2.Row, 1), Cells(Cell2.Row, 2)).Copy Destination:=ws.Range("A1").Offset(count, 0) count = count + 1 End If Next Cell2 

所以我只复制PRNA和单元格B旁边有PRNA单元格。

这是输出：

我不知道这里的问题是什么，也许它循环太快？

Answer 1

这将工作：

 Sub copyPRNA() Dim ows As Worksheet Dim tws As Worksheet Dim rng As Range Dim cell2 As Range Dim cnt As Long Set ows = ActiveSheet Set tws = Sheets("Sheet1") Set rng = ows.Range(ows.Range("B2"), ows.Range("B" & ows.Rows.Count).End(xlUp)) For Each cell2 In rng If cell2 = "PRNA" Then tws.Range("A" & tws.Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = ows.Range(cell2.Offset(, -1), cell2).Value End If Next cell2 End Sub 

始终在使用范围和单元格时，请限定父级。

Answer 2

你可以试试这个：你可能正在复制公式，这只会复制值。

  Sub CopyStuff() Dim rng3 As Range Dim cell2 As Range Set rng3 = ActiveSheet.Range("B1:B10") Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet2") Dim rng As Range Application.EnableEvents = False For Each cell2 In rng3 If UCase(cell2.Value) = UCase("PRNA") Then Set rng = cell2.Offset(0, -1) ws.Range(rng.Address).Resize(1, 2).Value = Array(rng.Value, cell2.Value) End If Next cell2 Application.EnableEvents = True End Sub