Excel & VBA: Copy rows into a new sheet based on cell value

一世执手 提交于 2019-12-02 13:36:49

As stated in earlier comments this is how you would Filter~>Copy~>Paste

Sub FilterAndCopy()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim lngLastRow As Long
Dim OKSheet As Worksheet, ErrorSheet As Worksheet

Set OKSheet = Sheets("Sheet2") ' Set This to the Sheet name you want all Ok's going to
Set ErrorSheet = Sheets("Sheet3") ' Set this to the Sheet name you want all Error's going to

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row


With Range("A1", "D" & lngLastRow)
    .AutoFilter
    .AutoFilter Field:=4, Criteria1:="OK"
    .Copy OKSheet.Range("A1")
    .AutoFilter Field:=4, Criteria1:="ERROR"
    .Copy ErrorSheet.Range("A1")
    .AutoFilter
End With


Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Try something like this...

Set sh = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Set sh3 = ThisWorkbook.Sheets("Sheet3")
lastrow = sh.Cells(Rows.Count, "A").End(xlUp).row
R = 2 
Do While R <= lastrow
     If sh.Range("D" & R) = "OK" Then
         sh.Range("A" & R & ":D" & R).Copy _
         Destination:=sh2.Range("A" & R)
     Else
         sh.Range("A" & R & ":D" & R).Copy _
         Destination:=sh3.Range("A" & R)
     End IF
Loop

You would need to change the rows/columns the data is coming from to suit your needs, but I wrote this based off your example.

EDIT: On second thought, I did some reading about filters and I would go with what others here have posted.

易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!