Copy entire row to new tab if a cell contains certain text

[TShaq]

Hello,

Apologies in advance and please excuse me if I've broken any rules with this post (it has been a while).

I've been trying to get a few different macros to work that copy an entire row and move it to an existing tab. The workbook is a 'To Do List' and contains the following tabs 'Level Exc', 'Level 1', '1 Week Window', 'Sam', 'Level 2', 'Level 3', 'Master List', and 'ABC=Success'. The idea is that when I add a new task to the Master List worksheet (this would include information entered in a row in cell's A-F) the macro would copy over the entire row based on what is entered in column F to another worksheet (listed above). What is entered in Column F can only be Level Exc, Level 1, Level 2, 1 Week Window, Sam, Level 2, and Level 3 (these are the priority levels). Example, I open up the workbook, go to the 'Master List' worksheet, and I enter: "Take out the Trash" in Cell A2, "Don't forget to replace the bag" in cell B2, "TShaq" (owner of task) in cell C2, "Waiting on garbageman to pick up" (status) in cell D2, "3/14/2017" (date of completion) in cell E2, and finally "Level 1" in cell F2. The entire row is then copied to the worksheet 'Level 1' in the same workbook. Further note, the ABC=Success worksheet would ideally have the row copied over if I put a check mark in Column G (not terribly worried about this right now). The below is what I've tried to start working with (found it in this forum and started to change it a bit), but it's getting a little beyond my ability and was wondering if someone might be able to help? The below could be totally wrong, it's been a longggg time since I've built a macro on my own.

Sub ToDoMove()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean

strArray = Array("Level Exc", "Level 1", "1 Week Window", "Sam", "Level 2", "Level 3")

Set wsSource = ActiveSheet

NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add

For I = 1 To NoRows

Set rngCells = wsSource.Range("A" & G & ":A" & G)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J

If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)

DestNoRows = DestNoRows + 1
End If
Next I
End Sub



Thanks!

TShaq

 

[tonyyy]

TShaq,

Another approach would be to use a Worksheet_Change event...

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo errHandler
If Not Intersect(Target, Columns(6)) Is Nothing Then
    Target.EntireRow.Copy Destination:=Sheets(Target.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
errHandler:
If Err.Number <> 0 Then MsgBox "Sorry, an error occurred.  The row was not copied." & vbCrLf & vbCrLf & _
    Err.Number & ": " & Err.Description
End Sub

Copy/Paste the code into the "Master List" worksheet module. Whenever an entry is made into Column F, that entire row is copied to the relevant worksheet.

Cheers,

tonyyy