Help with copy / paste certain criteria

[Bub_the_Zombie]

I have been looking at lots of the other forum questions on this topic and I am just not sure how to apply it to my code, can someone please help me with this. Below in the php tag is the long explanation, last time I posted I neglected a detail that caused some confusion, I do not think this needs it but I am including it.

What I need to do is to take the rows and data from the two social workers and copy / paste them onto worksheet two.

This will be part of a very long code, here are the parameters I am using

Dim WS As Worksheet
Set WS = Sheets("Patient Board")
Set WS2 = Sheets("Patient Board 2")

RANGE A50:AC100
Sorted by social worker in column J (starting at J50)

I need to take all the "HEATHER" and "TOM" rows from PATIENT BOARD 1 A50:AC100, paste them in PATIENT BOARD 2 A50:AC100.

Thanks!

Long explanation in here to save space

This will be used on two monitors to act as digital patient boards to assist four social workers in a psychiatric hospital. Currently the code I wrote works great on one monitor; it takes all the patients, separates the rows by social worker, adds a space in-between the different social workers, color codes by social worker, writes if the patient is either "in" or "out", provides them with all the data they need for the patient, plus has a few more bells and whistles.

The problem is because of monitor space it needs to be broken into two worksheets, monitor one displays one worksheet with two social workers, the second monitor displays the other worksheet and last two social workers. A simple cut and paste will not work because of the formulas written in column "d".

 

[Nine Zero]

I have been looking at lots of the other forum questions on this topic and I am just not sure how to apply it to my code, can someone please help me with this. Below in the php tag is the long explanation, last time I posted I neglected a detail that caused some confusion, I do not think this needs it but I am including it.

What I need to do is to take the rows and data from the two social workers and copy / paste them onto worksheet two.

This will be part of a very long code, here are the parameters I am using

Dim WS As Worksheet
Set WS = Sheets("Patient Board")
Set WS2 = Sheets("Patient Board 2")

RANGE A50:AC100
Sorted by social worker in column J (starting at J50)

I need to take all the "HEATHER" and "TOM" rows from PATIENT BOARD 1 A50:AC100, paste them in PATIENT BOARD 2 A50:AC100.

Thanks!

Long explanation in here to save space

This will be used on two monitors to act as digital patient boards to assist four social workers in a psychiatric hospital. Currently the code I wrote works great on one monitor; it takes all the patients, separates the rows by social worker, adds a space in-between the different social workers, color codes by social worker, writes if the patient is either "in" or "out", provides them with all the data they need for the patient, plus has a few more bells and whistles.

The problem is because of monitor space it needs to be broken into two worksheets, monitor one displays one worksheet with two social workers, the second monitor displays the other worksheet and last two social workers. A simple cut and paste will not work because of the formulas written in column "d".

Hey!

Try this out

Sub copyrows()     
    Dim tfCol As Range, Cell As Object
     
    Set tfCol = Range("A1:A50") 'Substitute with the range which includes your names values
     
    For Each Cell In tfCol
         
        If IsEmpty(Cell) Then
            Exit Sub
        End If
         
        If Cell.Value = "Heather" Or Cell.Value = "Tom" Then 'Make sure if your names are all caps then change them here
            Cell.EntireRow.Copy
            Sheet2.Select 'Substitute with your sheet
            ActiveSheet.Range("A65536").End(xlUp).Select
            Selection.Offset(1, 0).Select
            ActiveSheet.Paste
        End If
         
    Next
     
End Sub

 

[Bub_the_Zombie]

That is not working, it keeps freezing and I have to shut and restart the program.

I have been playing with this On and Off all day using your code as the skeleton.

This is what I currently have, it is giving me a debug notification on the IF statement. All attempts to correct it cause a different debug notification.

What needs to be changed to fix it?

Sheets("PATIENT BOARD").Select
    Range("A50:AC89").Select
    If Cell.Value = "HEATHER" Or Cell.Value = "TOM" Then
    Cell.EntireRow.Copy
    Sheets("PATIENT BOARD 2").Select
    Range("A50:AC89").Select
    Selection.Offset(1, 0).Select
            ActiveSheet.Paste
    END IF

 

[Krayons]

Sub test()

Dim wsOne As Worksheet, wsTwo As Worksheet
Dim lastRow As Integer, lastOutRow As Integer, i As Integer

Set wsOne = ThisWorkbook.Sheets("Patient Board")
Set wsTwo = ThisWorkbook.Sheets("Patient Board 2")

lastRow = wsOne.Cells(wsOne.Rows.Count, 1).End(xlUp).Row

MsgBox lastRow

For i = 1 To lastRow

    lastOutRow = wsTwo.Cells(wsTwo.Rows.Count, 1).End(xlUp).Row + 1
    
    If wsOne.Range("A" & i).Value = "Heather" Or wsOne.Range("A" & i).Value = "Tom" Then

        wsOne.Rows(i).EntireRow.Copy
        wsTwo.Range("A" & lastOutRow).PasteSpecial (xlPasteAll)

    End If

Next i

End Sub

 

[Bub_the_Zombie]

That seems to just give a message box for the last row one of the names was discovered.

That little bit of code (below) would be a small piece of a much larger vba command. Is there a way to just use that without setting another dim?

Sheets("PATIENT BOARD").Select
    Range("A50:AC89").Select
    If Cell.Value = "HEATHER" Or Cell.Value = "TOM" Then
    Cell.EntireRow.Copy
    Sheets("PATIENT BOARD 2").Select
    Range("A50:AC89").Select
    Selection.Offset(1, 0).Select
            ActiveSheet.Paste
    END IF

 

[Krayons]

That seems to just give a message box for the last row one of the names was discovered.

I threw that MsgBox in for testing. It also probably didnt work because I set it to start from row 1 (when I was testing). Change the number (in red) to whatever row your data actually starts on. I've set it to 50, as per your original post.

Sub test()

Dim wsOne As Worksheet, wsTwo As Worksheet
Dim lastRow As Integer, lastOutRow As Integer, i As Integer

Set wsOne = ThisWorkbook.Sheets("Patient Board")
Set wsTwo = ThisWorkbook.Sheets("Patient Board 2")

lastRow = wsOne.Cells(wsOne.Rows.Count, 1).End(xlUp).Row

For i = 50 To lastRow

    lastOutRow = wsTwo.Cells(wsTwo.Rows.Count, 1).End(xlUp).Row + 1
    
    If wsOne.Range("A" & i).Value = "Heather" Or wsOne.Range("A" & i).Value = "Tom" Then

        wsOne.Rows(i).EntireRow.Copy
        wsTwo.Range("A" & lastOutRow).PasteSpecial (xlPasteAll)

    End If

Next i

SendKeys "{ESC}"
wsOne.Activate
wsOne.Select
wsOne.Range("A1").Select

End Sub

That little bit of code (below) would be a small piece of a much larger vba command. Is there a way to just use that without setting another dim?

No.

You can download the example workbook from here:

TinyUpload.com - best file hosting solution, with no limits, totaly free

 

[Bub_the_Zombie]

Thanks!
I was able to play around with it to get it to work.

One more question, is there a way to make this cut not copy? Looking to delete the data that is being moved from the original worksheet after it is pasted on worksheet 2.

lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
For i = 50 To lastRow
    lastOutRow = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row + 1
    
    If WS.Range("J" & i).Value = "HEATHER" Or WS.Range("J" & i).Value = "TOM" Then
        WS.Rows(i).EntireRow.Copy
        WS2.Range("A" & lastOutRow).Paste Special(xlPasteAll)
    End If
Next i
SendKeys "{ESC}"
WS.Activate
WS.Select
WS.Range("A50").Select

 

[Bub_the_Zombie]

Solved:
Was able to convert something I found online to adjust your code.

Thanks again for the help

lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
For i = 50 To lastRow
    lastOutRow = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row + 1
    
    If WS.Range("J" & i).Value = "HEATHER" Or WS.Range("J" & i).Value = "TOM" Then
        'WS.Rows(i).EntireRow.Copy
        'WS2.Range("A" & lastOutRow).Paste Special(xlPasteAll)
        
        WS.Rows(i).EntireRow.Cut Destination:=WS2.Range("A" & lastOutRow)

    End If
Next i
SendKeys "{ESC}"
WS.Activate
WS.Select
WS.Range("A50").Select

 

[Krayons]

Solved:
Was able to convert something I found online to adjust your code.

Thanks again for the help

WS.Rows(i).EntireRow.Cut Destination:=WS2.Range("A" & lastOutRow)

Yup, you got it

I will also note, that bit I threw at the bottom:

SendKeys "{ESC}"
WS.Activate
WS.Select
WS.Range("A50").Select

Is not actually necessary. I often code things like that into my apps just because i'm particular like that.

Glad you got it figured out. Cheers.