Search array of sheets for specific array of words in column and copy that row to specified sheet

[slayer1957]

Good day,

I have a excel document which I require help with,

It must copy a row to sheet (TEAM) based on certain array of words (Approved, Cancelled, Completed, Task In Progress, Rejected) in column E (Range E2 to E500) on an array of sheets (Project, Projects1, Projects2, Projects3 etc.).

It must scan the array of sheets specified, in each sheets column E for the specific array of words and when it finds any of the array of words it must copy that row to TEAM sheet.

Hope someone can help. Thank you in advance

 

[Zot]

I'm assuming that you are working on a single workbook with one of the sheet named TEAM where you want to copy data to.

The code will loop through sheet and check each row in each sheet for keyword specified and copy matching row to sheet TEAM.

Sub Test()

Dim n As Long
Dim cell As Range, rng As Range
Dim ws As Worksheet, wsTeam As Worksheet
Dim DictWord As Object

Set DictWord = CreateObject("Scripting.Dictionary")
Set wsTeam = ThisWorkbook.Sheets("TEAM")

' Add keyword into dictionary
DictWord.Add "Approved", Nothing
DictWord.Add "Cancelled", Nothing
DictWord.Add "Completed", Nothing
DictWord.Add "Task In Progress", Nothing
DictWord.Add "Rejected", Nothing

For Each ws In ThisWorkbook.Sheets
    If Not ws.Name = "TEAM" Then
        Set rng = ws.Range("E2", "E500")
        For Each cell In rng
            If Not Len(cell.Value) = 0 Then
                If DictWord.Exists(cell.Value) Then
                    ' Find next empty row in wsTeam referring to column E
                    n = wsTeam.Cells(wsTeam.Rows.Count, "E").End(xlUp).Row + 1
                    ' This copy entire row. Change as required
                    ws.Range("A" & cell.Row).EntireRow.Copy wsTeam.Range("A" & n)
                End If
            End If
        Next
    End If
Next

End Sub

 

[slayer1957]

The workbook have a lot of sheets, not all must be checked for the keywords, but i need it to search only a specified array of sheet names as well (Projects, Projects1, Projects2, Projects3 etc.). I will add more sheet names as i put more projects sheets.

Do I just add ("Projects, Projects1, Projects2") etc. to the code "For Each ws In ThisWorkbook.Sheets("Projects, Projects1, Projects2")"

Thank you so far!

 

[Zot]

The workbook have a lot of sheets, not all must be checked for the keywords, but i need it to search only a specified array of sheet names as well (Projects, Projects1, Projects2, Projects3 etc.). I will add more sheet names as i put more projects sheets.

Do I just add ("Projects, Projects1, Projects2") etc. to the code "For Each ws In ThisWorkbook.Sheets("Projects, Projects1, Projects2")"

Thank you so far!

Assuming that the sheet prefix is always Project, then using Select would be easier. The code will look for any sheet with name started with word Project.

Sub Test()

Dim n As Long
Dim cell As Range, rng As Range
Dim ws As Worksheet, wsTeam As Worksheet
Dim DictWord As Object

Set DictWord = CreateObject("Scripting.Dictionary")
Set wsTeam = ThisWorkbook.Sheets("TEAM")

Application.ScreenUpdating = False

' Add keyword into dictionary
DictWord.Add "Approved", Nothing
DictWord.Add "Cancelled", Nothing
DictWord.Add "Completed", Nothing
DictWord.Add "Task In Progress", Nothing
DictWord.Add "Rejected", Nothing

For Each ws In ThisWorkbook.Sheets
    Select Case Left(ws.Name, 7)
        Case "Project"
            Set rng = ws.Range("E2", "E500")
            For Each cell In rng
                If Not Len(cell.Value) = 0 Then
                    If DictWord.Exists(cell.Value) Then
                        ' Find next empty row in wsTeam referring to column E
                        n = wsTeam.Cells(wsTeam.Rows.Count, "E").End(xlUp).Row + 1
                        ' This copy entire row. Change as required
                        ws.Range("A" & cell.Row).EntireRow.Copy wsTeam.Range("A" & n)
                    End If
                End If
            Next
    End Select
Next

Application.ScreenUpdating = True

End Sub