Macro to move a row based on a condition

[Kyle310]

I tried the Colo's HTML Maker to attach the file, but it's not working for me. I would be more than happy to send this file to make things easier.

Alright, I have a workbook with 3 tabs. The first tab doesn't matter. The second tab is called Roster and the third tab is called Discharged. I have about 15 counselor's that have 30-80 clients on their Roster tab. This becomes very unorganized because they are constantly adding new clients to the bottom of the tab. I recorded a macro that will alphabetize the clients by name (and hopefully keep the information next to the correct name). The other thing that I would like this macro to do is move the entire row onto the Discharge tab when a date for discharge is entered into the "Discharge Date" column.

A couple of important things: First is the information next to the name. If just the names move, all of the info will be for the wrong person. Next is the page itself; if the rows are being cut and pasted into tab 3, tab 2 will eventually run out of rows.

Again, I have a sample file to clarify but could not figure out how to post it. (This may show how dumb I can be, and I have to apologize in advance Thanks for your help.

 

[VoG]

Try this: right click the Roster sheet's tab, select View Code and paste in

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
If Target.Column = 4 Then 'D - change to suit
    If Target.Value <> "" Then
        Application.EnableEvents = False
        LR = Sheets("Discharge").Range("A" & Rows.Count).End(xlUp).Row
        With Target.EntireRow
            .Copy Destination:=Sheets("Discharge").Range("A" & LR + 1)
            .Delete
        End With
        Application.EnableEvents = True
    End If
End If
End Sub

Change the line in red so it references the Discharge Date column number.

Now when you enter a discharge date the row will be transferred to the Discharges sheet.

 

[Kyle310]

Ok, the Discharge Date column is AA, so here is what I changed the line in red to:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
If Target.Column = AA Then 'D - change to suit
If Target.Value <> "" Then
Application.EnableEvents = False
LR = Sheets("Discharge").Range("A" & Rows.Count).End(xlUp).Row
With Target.EntireRow
.Copy Destination:=Sheets("Discharge").Range("A" & LR + 1)
.Delete
End With
Application.EnableEvents = True
End If
End If
End Sub

I'm pretty sure I did it wrong. Thank you for the help!

 

[VoG]

It needs to be

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
If Target.Column = 27 Then
    If Target.Value <> "" Then
        Application.EnableEvents = False
        LR = Sheets("Discharge").Range("A" & Rows.Count).End(xlUp).Row
        With Target.EntireRow
            .Copy Destination:=Sheets("Discharge").Range("A" & LR + 1)
            .Delete
        End With
        Application.EnableEvents = True
    End If
End If
End Sub

On further thought, you need to ensure that your sort macro doesn't cause this code to be run. To do this add the following line in your code before the sort is done

Application.EnableEvents = False

Then after the sort

Application.EnableEvents = True

 

[Kyle310]

ADVERTISEMENT

Alright, I put the two lines before and after the sort(after figuring out the unhide command). It now looks like this:

Sub alpha()
'
' alpha Macro
' Macro recorded 3/4/2009 by WOLF3
'
' Application.EnableEvents = False
Rows("2:149").Select
ActiveSheet.Unprotect
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.ScrollRow = 2
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.EnableEvents = True
End Sub



Then I replaced AA with 27.

Nothing happend when I put a date in as 3/4, but when I typed in 3/4/09 it gave me an error that said the script was out of range. I clicked on DeBug, and it showed this

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
If Target.Column = 27 Then
If Target.Value <> "" Then
Application.EnableEvents = False
LR = Sheets("Discharge").Range("A" & Rows.Count).End(xlUp).Row
With Target.EntireRow
.Copy Destination:=Sheets("Discharge").Range("A" & LR + 1)
.Delete
End With
Application.EnableEvents = True
End If
End If
End Sub

The LR = Sheets("Discharge").Range("A" & LR + 2) line is highlighted yellow with an arrow to the left pointing at it.

Again, I apologize for not getting this right.

 

[Kyle310]

Hold the Phone!!

My wife walked in and noticed that I had spelled the Discharge tab wrong!

It seems to be working right now! You are awesome. Let me try this out a couple of times, but this is great. I have to figure out how to implement this on like 15 shared workbooks now, but this will save an unbeleivable amount of time.

 

[VoG]

ADVERTISEMENT

Is the discharge sheet actually called Discharge? No leading or trailing spaces?

 

[VoG]

So wives do have their uses!

 

[Kyle310]

It is now, I had actually spelled it Dischrge. I always seem to make those kinds of mistakes! Thank you so much, you have no idea.

Now I just have to figure out how to get both of these into everybody's shared files.

 

[Kyle310]

So wives do have their uses!

HA! Yeah, I guess I was wrong. I'll never hear the end of this one...