Move row based on value to two different sheets

[zmartee]

Hi!

I have a workbook with several sheets in it.
In one sheet (called "Väntar") I have rows with data (from row 3 to Column G) that updates with new
data through out the day. In column G there is a Dropdown list with the data "pending, OK, Fail".

Then I have two more sheets called "OK" and "Fail".

In the end of the day I want to be able to push a button with a Macro that moves all the rows
that has "OK" or "Fail" to the right sheet.

Im using this code now from an old post back from 2017. (Macro to move rows to another sheet based on cell value)
The problem i have with it is that it works just fine the first time i use
the button. But next time i use it it moves all the rows that has "OK" in it
correctly and puts the row at the bottom while it just keeps moving "Fail" to fail and overwriting the first
Row of data in the Fail sheet.

Is there anyone that can help me so that it works?

"
Option Explicit

Sub Diversion()


Dim x As Integer
Dim i As Integer
Dim y As Integer
Dim shSource As Worksheet
Dim shTarget1 As Worksheet
Dim shTarget2 As Worksheet


Set shSource = ThisWorkbook.Sheets("Väntar")
Set shTarget1 = ThisWorkbook.Sheets("OK")
Set shTarget2 = ThisWorkbook.Sheets("Fail")


If shTarget1.Cells(3, 7).Value = "Ok" Then
x = 2
Else
x = shTarget1.Cells(2, 7).CurrentRegion.Rows.Count + 1
End If

If shTarget2.Cells(3, 7).Value = "Fail" Then
y = 2
Else
y = shTarget2.Cells(2, 7).CurrentRegion.Rows.Count + 1
End If




i = 3


Do Until shSource.Cells(i, 7) = ""
If shSource.Cells(i, 7).Value = "OK" Then
shSource.Rows(i).copy
shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
x = x + 1

GoTo Line1

ElseIf shSource.Cells(i, 7).Value = "Fail" Then
shSource.Rows(i).copy
shTarget2.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
y = y + 1

GoTo Line1


End If
i = i + 1


Line1: Loop


End Sub

 

[vcoolio]

Hello Zmartee,

I don't know if you resolved your issue but here is a simplified code which should do the task for you:-

Option Explicit
Sub Test()

        Dim ar As Variant, i As Long, wsD As Worksheet
        ar = Array("OK", "Fail")

Application.ScreenUpdating = False

        For i = 0 To UBound(ar)
        Set wsD = Sheets(ar(i))
                With Sheet1.Range("G2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp))
                        .AutoFilter 1, ar(i), 7
                        .Offset(1).EntireRow.Copy wsD.Range("A" & Rows.Count).End(3)(2)
                        .Offset(1).EntireRow.Delete
                        .AutoFilter
                End With
        Next i

Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[zmartee]

Hello Zmartee,

I don't know if you resolved your issue but here is a simplified code which should do the task for you:-

Option Explicit
Sub Test()

        Dim ar As Variant, i As Long, wsD As Worksheet
        ar = Array("OK", "Fail")

Application.ScreenUpdating = False

        For i = 0 To UBound(ar)
        Set wsD = Sheets(ar(i))
                With Sheet1.Range("G2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp))
                        .AutoFilter 1, ar(i), 7
                        .Offset(1).EntireRow.Copy wsD.Range("A" & Rows.Count).End(3)(2)
                        .Offset(1).EntireRow.Delete
                        .AutoFilter
                End With
        Next i

Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

Yes!

This worked as a charm ^^

Thx for the help!

 

[vcoolio]

You're welcome Zmartee. I'm glad to have been able to assist.

Cheerio,
vcoolio.