Hi,
I'm making a macro to search words in the workbook ....
it creates a sheet "FindWord" with a link for the word ... as the
example:
Occurences of: test
Location Cell Text
Sheet1!F20 test
Sheet2!D50 test
Sheet5!C5 test
I notice that the function is with two errors:
1º - do not find values in merged cells
2º - do note find values in hidden cells
'this the part of the macro that makes the Search
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
GoTo Canceled
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
'Here I create a sheet "FindWord" with all occurrences found
'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 'veja abaixo o código
End If
(' Formatting code)
end sub
'that the macro that inserts the results found in the sheet "FindWord"
Sub AddSheetCode()
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
It is not working as I would like ....
Do you have any notion which error is this???
And where am I missing in the code ... ?
Thanks for the help ...
Ane
--~--~---------~--~----~------------~-------~--~----~
-------------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
-------------------------------------------------------------------------------------
-~----------~----~----~----~------~----~------~--~---
