Move row based on value to two different sheets

zmartee

New Member
Joined
May 11, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
1,112
Hello Zmartee,

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

VBA Code:
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.
 
Solution

zmartee

New Member
Joined
May 11, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hello Zmartee,

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

VBA Code:
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!
 

Watch MrExcel Video

Forum statistics

Threads
1,132,645
Messages
5,654,556
Members
418,140
Latest member
ahepple86

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top