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

问题

I'm a total newbie in Excel and VBA. I have a sheet like this:

A        B        C         D
someinfo someinfo someinfo OK
someinfo someinfo someinfo OK
someinfo someinfo someinfo ERROR
someinfo someinfo someinfo ERROR
someinfo someinfo someinfo OK
someinfo someinfo someinfo OK
someinfo someinfo someinfo ERROR
someinfo someinfo someinfo ERROR

Ok I'd like to copy the "OK" lines into a new sheet and the one with "ERROR" into another one.

How can I do that?

回答1:

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

回答2:

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.

来源：https://stackoverflow.com/questions/17070625/excel-vba-copy-rows-into-a-new-sheet-based-on-cell-value

标签

excel

vba

excel-vba

visual-studio-macros