Search certain column in all worksheets and paste rows to seperate worksheet.

[Chisholm]

Hi all,
I'm trying to search a particular column on all worksheets in a workbook, for either of two criteria (blank or "dnc"). I'd then like to copy certain columns (all is okay too) of that row to a seperate worksheet in that same workbook.
Basically, I'm trying to create a list on the last sheet that displays all items that which are either blank or have "dnc" in their "status" column.
I've included a sample worksheet from the workbook.
For example, I'd like the VBA to return rows 3 and 7 in a summary worksheet for the entire book.

[Chisholm]

I've been trying to modify the following code to do what I'd like.
Currently, I'd like to modify it to only search within one column in all worksheets, and search for blank cells in the same column.
I'd also like to add information from different columns in the same row as the result.


Option Compare Text
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0

'Returns screen size to set display column width
Private Function ScreenWidth()
ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function

Sub DoFindAll()
'Arguments required for initial use in a workbook
FindAll "", "True"
End Sub


Public Sub FindAll(Search As String, Reset As Boolean)

Dim WB As Workbook
Dim WS As Worksheet
Dim Cell As Range
Dim Prompt As String
Dim Title As String
Dim FindCell() As String
Dim FindSheet() As String
Dim FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As String
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String
Dim MyResponse As VbMsgBoxResult

If Search = "" Then
Prompt = "What do you want to search for in the worbook: " & vbNewLine & vbNewLine & Path
Title = "Search Criteria Input"
'Delete default search term if required
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
GoTo Canceled
End If
End If

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'Save found addresses and text into arrays
On Error Resume Next
Set WB = ActiveWorkbook
If Err = 0 Then
On Error GoTo 0
For Each WS In WB.Worksheets
'Omit results page from search
If WS.Name <> "FindWord" Then
With WB.Sheets(WS.Name).Cells
Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Counter = Counter + 1
ReDim Preserve FindCell(1 To Counter)
ReDim Preserve FindSheet(1 To Counter)
ReDim Preserve FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.Text
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
End If
Next
End If
On Error GoTo 0
'Response if no text found
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
Exit Sub
End If

'Create FindWord sheet in does not exist
On Error Resume Next
Sheets("FindWord").Select
If Err <> 0 Then
Debug.Print Err
'error occured so clear it
Err.Clear
Sheets.Add.Name = "FindWord"
Sheets("FindWord").Move After:=Sheets(Sheets.Count)
'Run macro to add code to ThisWorkbook
AddSheetCode
End If
'Write hyperlinks and texts to FindWord
Range("A3:L65536").ClearContents
Range("A1:L1").Interior.ColorIndex = 6
Range("A1").Value = "Occurences of:"
'Reset prevents looping of code when sheet changes
If Reset = True Then Range("B1").Value = Search
Range("A1:D2").Font.Bold = True
Range("A2").Value = "Location"
Range("B2").Value = "Cell Text"
Range("C2").Value = "Title"
Range("A1:B1").HorizontalAlignment = xlLeft
Range("A2:B2").HorizontalAlignment = xlCenter
'Adjust column width to suit display
Range("A:A").ColumnWidth = ScreenWidth / 60
Range("B:B").ColumnWidth = ScreenWidth / 60
Range("C:C").ColumnWidth = ScreenWidth / 60
For Counter = 1 To UBound(FindCell)
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
Address:="", SubAddress:=FindSheet(Counter) & "!" & FindCell(Counter), _
TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
Range("B" & Counter + 2).Value = FindText(Counter)
Next Counter
Range("B1").Select
Canceled:

Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub


Sub AddSheetCode()
'Thanks to Dragontooth
Dim strCode As String
Dim FWord As String
Dim WB As Workbook
Dim Sh
Dim I As Integer
Set WB = ActiveWorkbook

'Line to be inserted instead of 4th line below if code in Personal.xls
'& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
'Optional 4th line if code in workbook
'& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _

strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _
& "If Sh.Name = " & Chr(34) & "FindWord" & Chr(34) & " Then" & vbCr _
& "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
& "Cells(1,2).Select" & vbCr _
& "End if" & vbCr _
& "End if" & vbCr _
& "End Sub"
'Debug.Print strCode

'Write code to ThisWorkbook module
FWord = "ThisWorkbook"
For I = 1 To WB.VBProject.VBComponents.Count
If WB.VBProject.VBComponents.Item(I).Name = FWord Then
Exit For
End If
Next
If Not WB.VBProject.VBComponents.Item(I).CodeModule Is Nothing Then
If Not WB.VBProject.VBComponents.Item(I).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then
WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (strCode)
End If
End If
Set WB = Nothing

End Sub

[JimmyTheHand]

Chrisolm,
Try this sub before you start wrestling with that large piece of code that you want to modify.


Sub test()
Dim wsTgt As Worksheet, ws As Worksheet
Dim rngTgt As Range, rngSrc As Range, c As Range

Set wsTgt = ThisWorkbook.Worksheets.Add
wsTgt.Name = "Summary"
For Each ws In ThisWorkbook.Worksheets
If Not ws Is wsTgt Then
Set rngSrc = Range(ws.Range("B3"), ws.Range("B" & Rows.Count).End(xlUp))
Set rngTgt = wsTgt.Range("A" & Rows.Count).End(xlUp).Offset(1)
With rngSrc.Offset(, 13)
.Formula = "= IF(OR(F3=""DNC"", F3=""""),""x"", 1)"
.SpecialCells(xlCellTypeFormulas, xlTextValues).EntireRow.Copy rngTgt
.ClearContents
End With
End If
Next
wsTgt.Range("O:O").ClearContents
End Sub
Notes:
1) I used column "O" temporarily, for row selection purposes.
2) The code creates a new sheet in the workbook, which is then renamed to "Summary". If a "Summary" sheet already exists, an error will occur.
3) The code must be placed into the same workbook where the sheets are. This can be altered as needed.

Jimmy