VBA copy and paste based on cell value

Hi All,

I have a list of employee names, beside each name is the shift they are working. i.e DS or NS (day shift or night shift)

What I want to do is have a code look in the list and pull every row that has DS in it, and paste it into another sheet, but not to leave any spaces between rows as they are in the employee list.

I hope this can be easily done. I'm ok with vba, getting better every day!

Thanks in advance for any replies

I assummed employee names were in column A and the shift was in column B:

Sub RunMe()
Dim ws1 As Worksheet:   Set ws1 = Sheets("Sheet1") 'primary sheet
Dim ws2 As Worksheet:   Set ws2 = Sheets("Sheet2") 'output sheet
Dim str As String

str = "DS" 'you can change this if needed

With ws1
    .AutoFilterMode = False
    .Range("B1:B" & .Range("B" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=str
    .AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .AutoFilterMode = False
End With
    
End Sub

Hi, Thanks for the quick reply

I have been working on a code

Sub Shift()

Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Histogram").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("DS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("NS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Range("E" & r).Value = "DS" Then
        Range("B:G").Copy Destination:=Sheets("DS Sheet").Range("A" & lr2 + 1)
        lr2 = Sheets("DS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If Range("E" & r).Value = "NS" Then
        Range("B:G").Copy Destination:=Sheets("NS Sheet").Range("A" & lr3 + 1)
        lr3 = Sheets("NS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    Range("A1").Select
Next r
End Sub

However this keeps returning an error saying "we can't paste because the copy and paste area is not the same size", I have made sure they are exact replicas in size.

I realised I dont want to copy the whole row, jus column "B:G"

Any Ideas?

Change

 Range("B:G").Copy Destination:=Sheets("DS Sheet").Range("A" & lr2 + 1)

INTO

 Range("B" & r).Resize(, 6).Copy Sheets("DS Sheet").Range("A" & lr2 + 1)

I have made sure they are exact replicas in size.

But the code doesn't know that. The code thinks you are taking the entire column B:G and trying to paste it to a non-entire column. It would work if you told it to paste to A1 but not A50 (for example).

Probably would want to change to something more like this:

If Range("E" & r).Value = "DS" Then
    Range("B" & lr, "G" & lr).Copy Destination:=Sheets("DS Sheet").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If

Thanks for the reply.

That works ok, but my code now seems to copy all cells, regardless of the "NS" or "DS" and is pasting them all into "DS Sheet", and relabelling them all as "DS"

Here is my code as it is now

Sub Shift()

Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("Histogram").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("DS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("NS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Range("E" & r).Value = "DS" Then
        Range("B" & r).Resize(, 6).Copy Sheets("DS Sheet").Range("A" & lr2 + 1)
        lr2 = Sheets("DS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If Range("E" & r).Value = "NS" Then
        Range("B" & r).Resize(, 6).Copy Sheets("DS Sheet").Range("A" & lr3 + 1)
        lr3 = Sheets("NS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    Range("A1").Select
Next r
End Sub

Apologies, my last reply was incorrect, Its just not pasting the "NS" Values to the "NS Sheet"

Thanks for your code, but this too returns an error "Object not recognized".

I have attached an example workbook so you can see whats happening.

Thanks again for your time

You are you looping back ward? The first cell to be copied would be the last row in sheet Histogram.
Why are the other sheets layout look weird?

You should remove these lines from the body of the code. If you do not, the code will keep copying on the same row again and again.

lr2 = Sheets("DS Sheet").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("NS Sheet").Cells(Rows.Count, "A").End(xlUp).Row

Option Explicit
Sub Shift()

Dim lr As Long, r As Long
 With Sheets("Histogram")
    lr = .Cells(.Rows.Count, "A").End(xlUp).Row
    For r = lr To 2 Step -1
        If .Range("E" & r).Value = "DS" Then
            .Range("B" & r).Resize(, 6).Copy Sheets("DS Sheet").Cells(Rows.Count, "A").End(xlUp).Offset(1)
        ElseIf .Range("E" & r).Value = "NS" Then
            .Range("B" & r).Resize(, 6).Copy Sheets("NS Sheet").Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
    Next r
 End With
End Sub