Excel, find and move rows to different worksheets

Question

Stuart,

I'm new to VBA, thus my need for your help.

I need to search column 'D' of Sheet1 for 'Adam' or 'Adam RV' or 'Adam 30', then cut and paste the rows into his own worksheet named 'Adam'. Then do the same search in column 'D' of Sheet1 for 'Bob' or 'Bob TR' or 'Bob 40' and cut and paste the rows into his own worksheet named 'Bob'. I need to do this for 64 different people,thats 64 new worksheets. This is a weekly report that presently takes me several hrs to cut and paste.

Please help!

Answer

Sub moveNames()

   Dim iName As Integer
   Dim strName As String
   Dim wksSource As Worksheet, wksTarget As Worksheet
   Dim topCell As Range, botCell As Range, checkCell As Range
   Dim targetCell As Range

'transfer from Sheet1 all rows that show the name in 'col D... to the sheed named Bob or Adam

   Set wksSource = ThisWorkbook.Sheets("sheet1")
   For iName = 1 To 2
       strName = Choose(iName, "bob", "adam")
       Set wksTarget = ThisWorkbook.Sheets(strName)
       Set targetCell = wksTarget.Range("a1")
       Set topCell = wksSource.Range("d1")
       Set botCell = wksSource.Cells(topCell.SpecialCells(xlCellTypeLastCell).Row, 4)
       For Each checkCell In wksSource.Range(topCell, botCell)
           If LCase(Left(checkCell, Len(strName))) = strName Then
               checkCell.EntireRow.Copy
               wksTarget.Paste targetCell
               Application.CutCopyMode = False
               Set targetCell = targetCell.Offset(1)
           End If
       Next checkCell
   Next iName

End Sub