VBA to copy row automatically to another sheet based on cell value

[bennybanks]

Hi guys,
I would like help with a VBA code which automatically copies a row to a sheet based on value.
I would like the rows that have Good in Column B to be copied to the sheet "Good" and the rows that have Bad in column B to the sheet "Bad".

Thanks for your help.

 

[ThauThème]

Hi Bennybanks,

Maybe like That :

Sub Macro1()
Dim Sh As Worksheet
Dim G As Worksheet
Dim B As Worksheet
Dim TC As Variant
Dim I As Integer
Dim J As Integer
Dim KG As Integer
Dim KB As Integer
Dim LG As Byte
Dim LB As Byte
Dim TG() As Variant
Dim TB() As Variant

Set Sh = Sheets("Sheet1")
Set G = Sheets("Good")
Set B = Sheets("Bad")
G.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'delete old data in sheets Good
B.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'delete old data in sheets Bad
TC = Sh.Range("A1").CurrentRegion
KG = 1
KB = 1
For I = 2 To UBound(TC, 1)
    If TC(I, 2) = "Good" Then
        ReDim Preserve TG(1 To UBound(TC, 2), 1 To KG)
        For LG = 1 To UBound(TC, 2)
            TG(LG, KG) = TC(I, LG) 'tranposition
        Next LG
        KG = KG + 1
    End If
    If TC(I, 2) = "Bad" Then
        ReDim Preserve TB(1 To UBound(TC, 2), 1 To KB)
        For LB = 1 To UBound(TC, 2)
            TB(LB, KB) = TC(I, LB) 'transposition
        Next LB
        KB = KB + 1
    End If
Next I
If KG > 1 Then G.Range("A2").Resize(UBound(TG, 2), UBound(TG, 1)).Value = Application.Transpose(TG) 'transposition
If KB > 1 Then B.Range("A2").Resize(UBound(TB, 2), UBound(TB, 1)).Value = Application.Transpose(TB) 'transposition
End Sub

 

[Marc L]

Hi !

With advanced filter, ♪ easier, ♫ faster, … :​

Sub Demo()
With Sheet1
    Application.ScreenUpdating = False
    .Cells(2).Copy .Cells(19)

    For S& = 2 To 3
        Worksheets(S).Cells(1).CurrentRegion.Clear
        .[S2].Value = Worksheets(S).Name
        .Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .[S1:S2], Worksheets(S).Cells(1)
    Next

    .[S1:S2].Clear
End With
End Sub

Do you like ? So thanks to click on bottom right Like !​