多条件复制粘贴

Question

下面的 VBA 代码表示一个复制粘贴函数，由两个条件过滤。代码可以工作并完成工作，但问题是它生成结果的时间 - 这里有没有人知道编写相同代码的更有效方法？ 任何建议都非常感谢

Private Sub CommandButton3_Click()

  Dim c As Range, i As Integer, j As Integer


  Range("N6:R50").ClearContents
  i = 0
  For Each c In Range("B2:B50")
    If c = Range("O3").Value And Month(c.Offset(0, -1).Value) = Range("P1").Value Then
      Cells(6 + i, 14) = Cells(c.Row, c.Column - 1)
      Cells(6 + i, 15) = Cells(c.Row, c.Column + 1)
      Cells(6 + i, 16) = Cells(c.Row, c.Column + 2)
      Cells(6 + i, 17) = Cells(c.Row, c.Column + 3)
      Cells(6 + i, 18) = Cells(c.Row, c.Column + 4)
    End If
    i = i + 1
  Next c
   For j = 50 To 6 Step -1
    If Cells(j, 15) = "" Then
      Range("N" & j, "R" & j).Delete Shift:=xlUp
    End If
  Next j

End Sub

Answer 1

试试这个代码（你可能会根据你的标题改变范围 [6]）：

Private Sub CommandButton3_Click()

Dim rng As Range
Dim LR As Long
Application.ScreenUpadting = False
LR = Range("N6").CurrentRegion.Rows.Count + 5
Range("N6:R" & LR).ClearContents
LR = Range("A6").CurrentRegion.Rows.Count + 5
Range("A6").CurrentRegion.AutoFilter 1, Range("P1")
Range("A6").CurrentRegion.AutoFilter 2, Range("O3")
If Range("A6").CurrentRegion.SpecialCells(xlCellTypeVisible).Areas.Count > 1 Then
    Range("N6:N" & LR).SpecialCells(xlCellTypeVisible).Value = Range("B7:B" & LR).SpecialCells(xlCellTypeVisible).Value
    Range("O6:R" & LR).SpecialCells(xlCellTypeVisible).Value = Range("C7:F" & LR).SpecialCells(xlCellTypeVisible).Value
    Range("A6").CurrentRegion.AutoFilter
    Set rng = Range("N7:R" & LR).SpecialCells(xlCellTypeBlanks)
    rng.Rows.Delete Shift:=xlShiftUp
End If
End Sub