Macro to move rows to another sheet based on cell value

J

JarredE

New Member
Joined
Jul 12, 2017
Messages
9
Hi all, You've been incredibly helpful and kind to this point, and I need to rely on that kindness one more time.

I need a macro that will check a certain cell for a value, and upon finding that value, cut the entire row and paste it into a different sheet, then delete the now-empty row from the sheet.

The main sheet is called 'Diversion Notes'.

In Column D there are cells between row 5 and 104 with a drop down which has the options "Select", "Diverted", and "Admitted".

I need a macro I can link to a button that when clicked, checks the cells between D5 and D104 on worksheet 'Diversion Notes'.

If "Select" is in the cell, do nothing.

If "Diverted" is in the cell, cut the entire row containing that cell, and paste in the sheet 'FYTD Diversions' in the next available row in that sheet, which has the exact same formatting (number of columns, column headers, etc. as the 'Diversion Notes' sheet). Like the initial sheet, data begins in row 5 when that sheet is blank. Then the macro should delete the now-empty row from 'Diversion Notes'.

If "Admitted" is in the cell, do the exact same thing but paste the row into the next available row in the sheet 'FYTD Admissions'.

I've seen code that can do this, but unfortunately I'm lost when it comes to where to change the sheet names, cells to check, etc. within the code. I've tried a couple of times and it hasn't worked or it's done something completely unintended.

I know it's a big ask. Thanks in advance!
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Please let me know if it works as intended.

Code: 
Sub Diversion()


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


Set shSource = ThisWorkbook.Sheets("Diversion Notes")
Set shTarget1 = ThisWorkbook.Sheets("FYTD Diversions")
Set shTarget2 = ThisWorkbook.Sheets("FYTD Admissions")


If shTarget1.Cells(5, 4).Value = "" Then
x = 5
Else
x = shTarget1.Cells(5, 4).CurrentRegion.Rows.Count + 5
End If


If shTarget2.Cells(5, 4).Value = "" Then
y = 5
Else
y = shTarget2.Cells(5, 4).CurrentRegion.Rows.Count + 5
End If


i = 5


Do While i <= 104
    If Cells(i, 4).Value = "Diverted" Then
    shSource.Rows(i).Copy
    shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
    shSource.Rows(i).Delete
    x = x + 1
    GoTo Line1
    ElseIf Cells(i, 4).Value = "Admitted" 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
 
Upvote 0
This is awesome and it's almost perfect!

There's just one bug I'm experiencing:
The first time I run the macro, it works exactly as intended. However the second time I run it, it puts the row on the correct sheet, but with 2 blank rows between it and the previous row. Every time after the second, it puts the removed row on top of the previous row, overwriting the data there.
 
Upvote 0
Maybe there are some other workbook-specific information I should know? Because based on the description of your original posting, when you run 2nd time, there will be nothing to process, all "diverted" and "admitted" rows will be removed from the source tab and only "Select" will remain.
 
Upvote 0
Sorry - maybe this affects it.

This is a workbook that will continually have data entered into to it throughout a year. Essentially what I need is for the user to be able to enter data week by week, and at the end of each session of entering data, click a button to sort any of these rows which have been identified as "diverted" or "admitted" into the other sheets within the book. So this function will be run many times - at least once a week - and needs to sort those elements each time.

does that make sense?
 
Upvote 0
So you will continue to add new data below the remaining "Select" items on "Diversion Notes" tab? or you will only update the area between row 5 and row 104 with new data on "Diversion Notes" tab? I made small changes to the code, please try again and let me know.

Code: 
Sub Diversion()


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


Set shSource = ThisWorkbook.Sheets("Diversion Notes")
Set shTarget1 = ThisWorkbook.Sheets("FYTD Diversions")
Set shTarget2 = ThisWorkbook.Sheets("FYTD Admissions")


If shTarget1.Cells(5, 4).Value = "" Then
x = 5
Else
x = shTarget1.Cells(5, 4).CurrentRegion.Rows.Count + 5
End If


If shTarget2.Cells(5, 4).Value = "" Then
y = 5
Else
y = shTarget2.Cells(5, 4).CurrentRegion.Rows.Count + 5
End If


i = 5


Do Until shSource.Cells(i, 4) = ""
    If shSource.Cells(i, 4).Value = "Diverted" 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, 4).Value = "Admitted" 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
 
Upvote 0
So I hope you can help me out. I have a VERY similar situation. I have a workbook with two sheets (Active and Archive) that based on Open or Closed status from Column AB I want the row to be copied to Archive Sheet and deleted from Active sheet. I played with your VBA as much as I could figure it out and it seemed to work perfectly the first time I ran the macro. Then I ran it again after a few lines were updated on Active to mark it closed on cell AB and when it moved to Archive sheet it replaced the last row instead of adding it after the last row. This is something that I want to run continuously as new data will be adding and changed daily

Here is what I am running:

Code: 
[COLOR=#011993][FONT=Menlo]Sub[/FONT][/COLOR][COLOR=#000000][FONT=Menlo] Archive()[/FONT][/COLOR][COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Dim[COLOR=#000000] x [/COLOR]As[COLOR=#000000] [/COLOR]Integer[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Dim[COLOR=#000000] y [/COLOR]As[COLOR=#000000] [/COLOR]Integer[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Dim[COLOR=#000000] i [/COLOR]As[COLOR=#000000] [/COLOR]Integer[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Dim[/COLOR] shSource [COLOR=#011993]As[/COLOR] Worksheet[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Dim[/COLOR] shTarget1 [COLOR=#011993]As[/COLOR] Worksheet[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Set[/COLOR] shSource = ThisWorkbook.Sheets("Active")[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Set[/COLOR] shTarget1 = ThisWorkbook.Sheets("Archive")[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]If[/COLOR] shTarget1.Cells(2, 28).Value = "" [COLOR=#011993]Then[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]x = 2[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]Else[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]x = shTarget1.Cells(2, 28).CurrentRegion.Rows.Count[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]End[COLOR=#000000] [/COLOR]If[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]i = 2[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo][COLOR=#011993]Do[/COLOR] [COLOR=#011993]Until[/COLOR] shSource.Cells(i, 28) = ""[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]    [COLOR=#011993]If[/COLOR] shSource.Cells(i, 28).Value = "Closed" [COLOR=#011993]Then[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]    shSource.Rows(i).Copy[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]    shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]    shSource.Rows(i).Delete[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]    x = x + 1[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]    [COLOR=#011993]GoTo[/COLOR] Line1[/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]End[COLOR=#000000] [/COLOR]If[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]i = i + 1[/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo]Line1: [COLOR=#011993]Loop[/COLOR][/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#000000][FONT=Menlo] [/FONT][/COLOR]
[COLOR=#011993][FONT=Menlo]End[/FONT][/COLOR][COLOR=#000000][FONT=Menlo] [/FONT][/COLOR][COLOR=#011993][FONT=Menlo]Sub[/FONT][/COLOR]


Also I have another macro I would like to run off topic. In the same workbook and the same sheet Active I have columns B:P I want to have it refresh all the fields from each cell by doing a VLOOKUP on value in Cell B to another sheet called "Webcycle" and if there isn't a value from Cell B to match then copy the row into Active sheet. So to explain more in the sheet called Webcycle I will have either NEW data I would like to be copied to Active Sheet or data I would like to refresh on Active Sheet. Formatting between the two sheet are the exact same as far as headers and stuff. Cell B would have the Document Number I would like to use to determine if its going to refresh the data from Sheet Webcycle or copy the data to Active Sheet. If its copying new data from Webcycle Sheet to Active Sheet then copy the new data at the bottom after the last row. If its refreshing the data then just copy it over the existing cells.

I would greatly appreciate your assistance. You seem to know your stuff and I really need to have this working. Let me know if you have any followup questions.

SooperTee said:
So you will continue to add new data below the remaining "Select" items on "Diversion Notes" tab? or you will only update the area between row 5 and row 104 with new data on "Diversion Notes" tab? I made small changes to the code, please try again and let me know.
Click to expand...
 
Upvote 0
Make the change in red to this line
Code: 
[COLOR=#000000][FONT=Menlo]x = shTarget1.Cells(2, 28).CurrentRegion.Rows.Count[/FONT][/COLOR][COLOR=#ff0000][FONT=Menlo] + 1[/FONT][/COLOR]
As for your other request you will need to start a new thread
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
cut/copy and paste row based on cell value not being equal to specific text
Replies
6
Views
494
mlan1604
M
M
  • Question Question
Macro to ignore first row, or move with multiple criteria
Replies
2
Views
295
Alex Blakenburg
A
W
  • Question Question
Move Row to Another Sheet Based on Multiple Cell Values
Replies
9
Views
486
jolivanes
jolivanes
J
  • Solved
Move Changed Rows to another sheet
2
Replies
15
Views
256
JGOpsMgr
J
J
  • Question Question
Using Sheets().Select in a Worksheet_Activate() macro
2
Replies
10
Views
446
jdun
J

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

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
Back
Top