Macro to copy specific cell if match critera

I am looking for a way to copy/paste information from the third column of the name range to a different sheet based on a key word in the second column (columns in the name range are E:G). The information needs to be paste in a different sheet starting in B6. 2 of the columns could have the same key word but I need it to ignore the first column in the name range.

Current Code that grabs everything that has "Rotating" in a cell. (found it online in the process trying to make it work for me)

Sub Grab_Shift()
     
    Dim dRef As String, rng As Range, ws1 As Worksheet
    Dim x As Long, y As Long, ff As String, PasteTo As Range
    dRef = "Rotating"
     
    Set rng = Sheets("MSF").Range("NamenShift")
    Set ws1 = Sheets("Sheet1")
     
    x = rng.Rows.count
    y = rng.Columns.count
     
    Set cell = rng.Find(dRef, rng.Cells(x, y), , xlWhole)
    If Not cell Is Nothing Then
        ff = cell.Address
        Do
            Set PasteTo = ws1.Range("b" & Rows.count).End(xlUp).Offset(1)
            PasteTo.Resize(, y).Value = rng.Rows(cell.Row - rng.Row + 1).Value
            Set cell = rng.FindNext(cell)
        Loop Until cell.Address = ff
    End If
    Set ws1 = Nothing: Set rng = Nothing
    Set cell = Nothing: Set PasteTo = Nothing
     
End Sub

Try this

Sub Grab_Shift()
     
    Dim dRef As String, rng As Range, ws1 As Worksheet
    Dim x As Long, y As Long, ff As String, PasteTo As Range
    
    Dim strRng
    Dim intLast As Integer
    Dim intFirst As Integer
    Dim intRow As Integer
    
    dRef = "Rotating"
     
    Set rng = Sheets("MSF").Range("NamenShift")
    Set ws1 = Sheets("Sheet1")
     
    ''if you dont already have something in B6 on sheet 1 then set a header in B5 so that your new data starts at B6
    ws1.Cells(5, 2).Value = "New Data"
    
    ''find the column to be used for copying data (last column)
    strRng = rng.Address(ReferenceStyle:=xlR1C1)
    intLast = Mid(strRng, InStrRev(strRng, "C") + 1)
    ''mark the first column to exclude this if the search valve (Rotating) is found
    intFirst = Mid(strRng, InStr(strRng, "C") + 1, (InStr(strRng, ":") - 1) - (InStr(strRng, "C")))
    
    x = rng.Rows.Count
    y = rng.Columns.Count
    
    Set cell = rng.Find(dRef, rng.Cells(x, y), , xlWhole)
    If Not cell Is Nothing Then
        ff = cell.Address
        Do
            ''this allows you to write to a specific row
            intRow = ws1.Cells(Rows.Count, "B").End(xlUp).Row + 1
            ''make sure we are not looking at the first column
            If cell.Column > intFirst Then
                Worksheets("Sheet1").Cells(intRow, 2).Value = Worksheets("MSF").Cells(cell.Row, intLast).Value
            End If
            Set cell = rng.FindNext(cell)
        
        Loop While cell.Address <> ff
    End If
    Set ws1 = Nothing: Set rng = Nothing
    Set cell = Nothing: Set PasteTo = Nothing
     
End Sub

I took another look at it and it could be shortened to this

Sub Grab_Shift2()
     
    Dim dRef As String, rng As Range, ws1 As Worksheet
    Dim x As Long, y As Long, ff As String, PasteTo As Range
    
    Dim lngFillRow As Long
    Dim record As Range
    ''Dim lngOffset As Long
    
    dRef = "Rotating"
     
    Set rng = Sheets("MSF").Range("NamenShift")
    Set ws1 = Sheets("Sheet1")
     
    lngFillRow = ws1.Cells(Rows.Count, "B").End(xlUp).Row + 1
    If lngFillRow < 6 Then
        lngFillRow = 6
    End If
     
    For Each record In rng
        If record.Offset(Columnoffset:=1).Value = dRef Then
            ws1.Cells(lngFillRow, 2).Value = record.Offset(Columnoffset:=2).Value
            lngFillRow = lngFillRow + 1
        End If
    Next record
    
    Set ws1 = Nothing: Set rng = Nothing
     
End Sub