• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Userform to find data on all worksheets in workbook

sealion1

Member
Hi all,

I am looking to create a userform that searches data on all worksheets in a workbook and tells you when a specific customer tracking number has been found.

The workbook will have three tabs that will need to be searched from the userform, they are "AM", "PM" and "Weekend".

I am struggling at the moment and don't know where to start - any help is appreciated!

Thanks.
 
You can use the Find method (which is the same Find you use in the workbook) to quickly search a range of cells. Since we have multiple sheets, we'll need to loop over the sheets. Something like this should help you get started:
Code:
Sub FindSomething()
Dim ws As Worksheet
Dim xStr As Variant
Dim fCell As Range

xStr = InputBox("What are we looking for?", "Find this")

If xStr = "" Then Exit Sub

For Each ws In ThisWorkbook.Worksheets
    On Error Resume Next
    Set fCell = ws.Cells.Find(xStr)
    On Error GoTo 0
    If Not fCell Is Nothing Then
        MsgBox "We found it on sheet: " & ws.Name
        Exit Sub
    End If
Next ws

'IF we get to here, we didn't find it
MsgBox "Sorry, I couldn't find that."
End Sub
 
This line:
Code:
For Each ws In ThisWorkbook.Worksheets
does that for you. It says to look at each worksheet within this workbook. It checks the first sheet, and if not found moves to next sheet. If it finds a match anywhere, it stops. If it never finds a match, it tells you at the end.
 
Brilliant - that does work. I'm not sure why I couldn't get it to work before.

Three things:

1: Is there any way it could be put into a userform?

2: Could it also give the cell reference that it has found the data in?

3: Is there any way of going clicking something that takes you straight to the cell location where the tracking number has been found?

Sorry for asking so much - any help would be amazing!
 
We could...but I will note that what you describe is fairly close to the built-in Find function. If you select "Workbook" here:
upload_2015-1-7_14-59-30.png
you could then hit the FindAll button, and the tool will show you all results, and give you a list that you can click on to select the cell(s) in question. Would that suffice?
upload_2015-1-7_15-0-1.png
 
Hi Luke,

Effectively, I need to VBA the find function that you show above. There are quite a few people who I work with who don't understand excel, so I need to make it as easy as possible with a click button.

Any help would be great.
 
I have found the following code, but it doesn't quite work as it doesn't filter through all the sheets or allow me to input what I want to search for - thoughts?

Code:
Sub HighlightFindValues()

'PURPOSE: Highlight all cells containing a specified values
'SOURCE: www.TheSpreadsheetGuru.com

Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

'What value do you want to find (must be in string form)?
 fnd = "Kentucky"

Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)

'Test to see if anything was found
 If Not FoundCell Is Nothing Then
 FirstFound = FoundCell.Address
 Else
 GoTo NothingFound
 End If

Set rng = FoundCell

'Loop until cycled through all unique finds
 Do Until FoundCell Is Nothing
 'Find next cell with fnd value
 Set FoundCell = myRange.FindNext(after:=FoundCell)
 
 'Add found cell to rng range variable
 Set rng = Union(rng, FoundCell)
 
 'Test to see if cycled through to first found cell
 If FoundCell.Address = FirstFound Then Exit Do
 
 Loop

'Highlight Found cells yellow
 rng.Interior.Color = RGB(255, 255, 0)
 
Exit Sub

'Error Handler
NothingFound:
 MsgBox "No values were found in this worksheet"

End Sub
 
Here's a code I built recently for someone else this might work:
Code:
Sub FindAll()
Dim ws As Worksheet
Dim firstAddress As String
Dim userInput As String
Dim fCell As Range
Dim foundOnce As Boolean

userInput = InputBox("What are we looking for?", "Find this")
If userInput = "" Then Exit Sub 'User cancelled

For Each ws In ThisWorkbook.Worksheets
    firstAddress = ""
    Set fCell = ws.Cells.Find(what:=userInput, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
   
    'Cell must be unlocked to count, but first need to insure fCell exists, or error occurs
    If Not fCell Is Nothing Then
        'We found something
        firstAddress = fCell.Address
        foundOnce = True
       
        ws.Select
        'Loop through all values within current sheet
        Do
            fCell.Select
            If MsgBox("Would you like to keep searching?", vbYesNo + vbDefaultButton1, "Keep searching?") = vbNo Then
                'Found what we want, exit sub
                Exit Sub
            End If
            Set fCell = ws.Cells.FindNext(fCell)
        Loop Until fCell.Address = firstAddress
    End If
Next ws

If foundOnce Then
    MsgBox "No other cell(s) found"
Else
    MsgBox "Value not found"
End If
End Sub
Steps through each cell one at a time. Or, to adapt what you posted above, see below. Doesn't pick each cell, but goes through and highlights them all.
Code:
Sub HighlightFindValues()

'PURPOSE: Highlight all cells containing a specified values
'SOURCE: www.TheSpreadsheetGuru.com
'Edited by Luke M of chandoo.org
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim ws As Worksheet

'What value do you want to find (must be in string form)?
fnd = InputBox("What are we looking for?", "Find this")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
    Set myRange = ws.UsedRange
    Set LastCell = myRange.Cells(myRange.Cells.Count)
    Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
   
    'Test to see if anything was found
    If Not FoundCell Is Nothing Then
        FirstFound = FoundCell.Address
    Else
        GoTo NothingFound
    End If
   
    Set rng = FoundCell
   
    'Loop until cycled through all unique finds
    Do Until FoundCell Is Nothing
         'Find next cell with fnd value
        Set FoundCell = myRange.FindNext(after:=FoundCell)
         
         'Add found cell to rng range variable
        Set rng = Union(rng, FoundCell)
         
         'Test to see if cycled through to first found cell
        If FoundCell.Address = FirstFound Then Exit Do
     
    Loop
   
    'Highlight Found cells yellow
    rng.Interior.Color = RGB(255, 255, 0)
NothingFound:
    'Reset variables
    Set rng = Nothing
    Set FoundCell = Nothing
    Set LastCell = Nothing
    Set myRange = Nothing
    Set rng = Nothing
    FirstFound = ""
Next ws
   
Application.ScreenUpdating = True

End Sub
 
Perfect - thanks Luke.

Would this be easy for me to put into a userform?
In short, no. It would not be easy. We'd have to create a user form with some sort of text box(es). You would then be loading the text box with data from all the found cells (such as address, contents, etc.). We would then either need to resize the form/box to fit, or make the box scrollable.

Now, being a bit cheeky, we could make a "user form" pop up that is basically a short instruction on how to properly use the built-in Find function. :p
 
Hi Luke,

I have found the below code - which looks like it would work, but can't get it to search the tabs on my spreadsheet?

Any ideas?

Code:
'------------------------  ExcelCampus.com  ------------------------

'Find All User Form

'

'by Jon Acampora, jon@excelcampus.com

'

'Description: The form uses the the FindAll function by Chip Pearson

'  to find and return results to a listbox as the user types.

'  The user can click on a result to go to the cell listed in

'  the results.

'

'Date: 03/19/2013

'

'-------------------------------------------------------------------------



Dim strSearchAddress As String



Private Sub UserForm_Initialize()

'Define Search Address



Dim ws As Worksheet

Dim lRow As Long

Dim lCol As Long

Dim lMaxRow As Long

Dim lMaxCol As Long



  lMaxRow = 0

  lMaxCol = 0

 

 'Set range to search

  For Each ws In ActiveWorkbook.Worksheets

  lRow = ws.UsedRange.Cells.Rows.Count

  lCol = ws.UsedRange.Cells.Columns.Count



  If lRow > lMaxRow Then lMaxRow = lRow

  If lCol > lMaxCol Then lMaxCol = lCol

  Next ws

 

 strSearchAddress = Range(Cells(1, 1), Cells(lMaxRow, lMaxCol)).Address



End Sub



Private Sub TextBox_Find_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

'Calls the FindAllMatches routine as user types text in the textbox



  Call FindAllMatches

 

End Sub



Private Sub Label_ClearFind_Click()

'Clears the find text box and sets focus



  Me.TextBox_Find.Text = ""

  Me.TextBox_Find.SetFocus

 

End Sub



Sub FindAllMatches()

'Find all matches on activesheet

'Called by: TextBox_Find_KeyUp event



Dim FindWhat As Variant

Dim FoundCells As Variant

Dim FoundCell As Range

Dim arrResults() As Variant

Dim lFound As Long

Dim lSearchCol As Long

Dim lLastRow As Long

Dim lWS As Long

Dim lCount As Long

Dim ws As Worksheet

Dim lRow As Long

Dim lCol As Long

Dim lMaxRow As Long

Dim lMaxCol As Long

 

 If Len(f_FindAll.TextBox_Find.Value) > 1 Then 'Do search if text in find box is longer than 1 character.

 

 FindWhat = f_FindAll.TextBox_Find.Value

  'Calls the FindAll function

  FoundCells = FindAllOnWorksheets(Nothing, Empty, SearchAddress:=strSearchAddress, _

  FindWhat:=FindWhat, _

  LookIn:=xlValues, _

  LookAt:=xlPart, _

  SearchOrder:=xlByColumns, _

  MatchCase:=False, _

  BeginsWith:=vbNullString, _

  EndsWith:=vbNullString, _

  BeginEndCompare:=vbTextCompare)



  'Add results of FindAll to an array

  lCount = 0

  For lWS = LBound(FoundCells) To UBound(FoundCells)

  If Not FoundCells(lWS) Is Nothing Then

  lCount = lCount + FoundCells(lWS).Count

  End If

  Next lWS

 

 If lCount = 0 Then

  ReDim arrResults(1 To 1, 1 To 2)

  arrResults(1, 1) = "No Results"

 

 Else

 

 ReDim arrResults(1 To lCount, 1 To 2)

 

 lFound = 1

  For lWS = LBound(FoundCells) To UBound(FoundCells)

   If Not FoundCells(lWS) Is Nothing Then

  For Each FoundCell In FoundCells(lWS)

  arrResults(lFound, 1) = FoundCell.Value

  arrResults(lFound, 2) = "'" & FoundCell.Parent.Name & "'!" & FoundCell.Address(External:=False)

  lFound = lFound + 1

  Next FoundCell

  End If

  Next lWS

  End If

 

 'Populate the listbox with the array

  Me.ListBox_Results.List = arrResults

 

 Else

  Me.ListBox_Results.Clear

  End If

 

End Sub



Private Sub ListBox_Results_Click()

'Go to selection on sheet when result is clicked



Dim strAddress As String

Dim strSheet As String

Dim strCell As String

Dim l As Long



  For l = 0 To ListBox_Results.ListCount

  If ListBox_Results.Selected(l) = True Then

  strAddress = ListBox_Results.List(l, 1)

  strSheet = Replace(Mid(strAddress, 1, InStr(1, strAddress, "!") - 1), "'", "")

  Worksheets(strSheet).Select

  Worksheets(strSheet).Range(strAddress).Select

  GoTo EndLoop

  End If

  Next l



EndLoop:

 

End Sub



Private Sub CommandButton_Close_Click()

'Close the userform



  Unload Me

 

End Sub
 
Thanks Luke - it was a great find!

Quick question:

- How do I password protect each tab, so that the tabs can be viewed, but not amended when data is put on it?
 
Under the Review Tab, protect sheet.
upload_2015-1-8_14-19-42.png
you'll want to be sure to leave the "select locked cells" option checked, so that the userform macro can select the protected cells when user clicks on them.
 
I've tried that option, but when I do - I got the following message:
 

Attachments

  • upload_2015-1-8_22-33-30.png
    upload_2015-1-8_22-33-30.png
    11.9 KB · Views: 25
@sealion1

Please try below code in Workbook Open Module.

Code:
Dim wSheet As Worksheet
    For Each wSheet In ThisWorkbook.Worksheets

        wSheet.Protect Password:="Password", _
        UserInterFaceOnly:=True, _
    
Next wSheet

Change the Password to your choice.

Regards,
 
Alternatively, I'd be curious if you could hit the "debug" button on that error message, and see which line is causing the problem. A Find All type macro shouldn't be trying to edit the cells.
 
@Somendra Misra

I have tried to do what you said, but it doesn't work:

upload_2015-1-9_15-19-37.png

@Luke M

Error message says this when I am trying to add information to the tab that has been protected. In essence, I want to be able to add data to the tab but other users cannot delete or amend this data without a password.

upload_2015-1-9_15-21-43.png

Debug shows this:

upload_2015-1-9_15-22-31.png
Thanks :)
 
@sealion1

Sorry my mistake, I did it a bit fast

try this code,

Code:
Dim wSheet As Worksheet
    For Each wSheet In ThisWorkbook.Worksheets

        wSheet.Protect Password:="Password", _
        UserInterFaceOnly:=True
  
Next wSheet


How have you had defined nextrow?

Regards,
 
@Somendra Misra

Please see the below code I am using, as I don't understand what you mean:

Code:
Private Sub cmdShipment_Click()
Dim X As Integer
Dim nextrow As Range
Dim crntsheet As String
If Me.Controls("Shipment2").Value = "AM Shift" Then
crntsheet = "AM"
ElseIf Me.Controls("Shipment2").Value = "PM Shift" Then
crntsheet = "PM"
ElseIf Me.Controls("Shipment2").Value = "Flex Shift" Then
crntsheet = "WEEKEND"
End If
'On Error GoTo cmdSupplier_Click_Error

Set nextrow = Worksheets(crntsheet).Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)

For X = 1 To 4
If Me.Controls("Shipment" & X).Value = "" Then
MsgBox "Missing data"
Exit Sub
End If
Next
If WorksheetFunction.CountIf(Sheet2.Range("E:E"), Me.Shipment3.Value) > 0 Then
MsgBox "This Shipment already exists"
Exit Sub
End If

For X = 1 To 4
nextrow = Me.Controls("Shipment" & X).Value
Set nextrow = nextrow.Offset(0, 1)
Next
'clear
For X = 1 To 4
Me.Controls("Shipment" & X).Value = ""
Next

On Error GoTo 0
Exit Sub

cmdSupplier_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdSupplier_Click of Form frmVendor"
End Sub


Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub Shipment1_Change()

End Sub

Private Sub Shipment2_Change()

End Sub
 
@sealion1

Nextrow is defined as Range and by the statement where you are getting error is trying to put a value on a protected sheet, and hence may be an error.

Try my code on a worksheet Open module.

Regards,
 
Back
Top