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

slayer1957

New Member
Joined
Jan 9, 2017
Messages
36
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
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
2,006
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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

New Member
Joined
Jan 9, 2017
Messages
36
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

Well-known Member
Joined
Nov 26, 2020
Messages
2,006
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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
 
Solution
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,396
Messages
5,769,837
Members
425,574
Latest member
grimeslisa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top