counting on results in vba

Topic

New Reply

I’m back people, how are you all. I have been away for about 18 months now maybe longer. Starting to get back into visual basic once again. So here is my situation I have this code that allows me to perdorm a search from a command button on my user form. But what I need is for it to also count how many times the item I searched for shows up within the spreedsheet. I.e. If I need to look at all data for january 1st 2010 that was entered (1/1/2010) i need it to show 20 items found. for ev ery item that was entered on that date.
also I need to know how to go back to the original worksheet once done.
Here is my code so far.

Code:

Private Sub SearchAreas_Click()
    Dim ThisAddress$, Found, FirstAddress
    Dim Lost$, N&, NextSheet&
    Dim CurrentArea As Range, SelectedRegion As Range
    Dim Reply As VbMsgBoxResult
    Dim FirstSheet As Worksheet
    Dim Ws As Worksheet
    Dim Wks As Worksheet
    Dim Sht As Worksheet
     
    Set FirstSheet = ActiveSheet '< bookmark start sheet
    Lost = InputBox(prompt:="What are you looking for?", _
    Title:="Find what?", Default:="*")
    If Lost = Empty Then End
    For Each Ws In Worksheets
        Ws.Select
        With ActiveSheet.Cells
            Set FirstAddress = .Find(What:=Lost, LookIn:=xlValues)
            If FirstAddress Is Nothing Then '< blank sheet
                GoTo NextSheet
            End If
            FirstAddress.CurrentRegion.Select
            Selection.Interior.ColorIndex = 6 '< yellow
             '//colour the 'Lost' font red, cell colour blank
            With Selection
                Set Found = .Find(What:=Lost, LookIn:=xlValues)
                If Not Found Is Nothing Then
                    FirstAddress = Found.Address
                    Do
                        Found.Interior.ColorIndex = 3 '< red
                        Found.Font.Bold = True
                        Found.Font.ColorIndex = 2
                        Set Found = .FindNext(Found)
                    Loop While Not Found Is Nothing And Found. _
                    Address  FirstAddress
                End If
            End With
            Reply = MsgBox("Is this the " & Lost & " you're looking for?", _
            vbQuestion + vbYesNoCancel, "Current Region")
             '//restore the 'Lost' font and cell colour
            Set Found = .Find(What:=Lost, LookIn:=xlValues)
            If Not Found Is Nothing Then
                FirstAddress = Found.Address
                Do
                    Found.Font.Bold = False
                    Found.Font.ColorIndex = 0
                    Set Found = .FindNext(Found)
                Loop While Not Found Is Nothing And Found. _
                Address  FirstAddress
            End If
             '//restore the selection colour
            Selection.Interior.ColorIndex = xlNone
            Set FirstAddress = .Find(What:=Lost, LookIn:=xlValues)
            If Reply = vbCancel Then End
             '//dont look further
            If Reply = vbYes Then
                Set SelectedRegion = Selection
GoTo Finish:
            End If
             '//case=not this one
            ThisAddress = FirstAddress.Address
            Set CurrentArea = Selection
            Do
                If Intersect(CurrentArea, Selection) Is Nothing Then
                    With Selection.Interior
                        .ColorIndex = 6
                        .Pattern = xlSolid
                    End With
                     '//colour the 'Lost' font red, cell colour blank
                    With Selection
                        Set Found = .Find(What:=Lost, LookIn:=xlValues)
                        If Not Found Is Nothing Then
                            FirstAddress = Found.Address
                            Do
                                Found.Interior.ColorIndex = 3
                                Found.Font.Bold = True
                                Found.Font.ColorIndex = 2
                                Set Found = .FindNext(Found)
                            Loop While Not Found Is Nothing And Found. _
                            Address  FirstAddress
                        End If
                    End With
                    Reply = MsgBox("Is this the " & Lost & " you're looking for?", _
                    vbQuestion + vbYesNoCancel, "Current Region")
                     '//restore the 'Lost' font and cell colour
                    Set Found = .Find(What:=Lost, LookIn:=xlValues)
                    If Not Found Is Nothing Then
                        FirstAddress = Found.Address
                        Do
                            Found.Font.Bold = False
                            Found.Font.ColorIndex = 0
                            Set Found = .FindNext(Found)
                        Loop While Not Found Is Nothing And Found. _
                        Address  FirstAddress
                    End If
                     '//restore the selection colour
                    Selection.Interior.ColorIndex = xlNone
                    Set FirstAddress = .Find(What:=Lost, _
                    LookIn:=xlValues)
                    If Reply = vbCancel Then End
                    If Reply = vbYes Then
                        Set SelectedRegion = Selection
GoTo Finish:
                    End If
                End If
                If CurrentArea Is Nothing Then
                    Set CurrentArea = Selection
                Else
                    Set CurrentArea = Union(CurrentArea, Selection)
                End If
                Set FirstAddress = .FindNext(FirstAddress)
                FirstAddress.CurrentRegion.Select
            Loop While Not FirstAddress Is Nothing And FirstAddress. _
            Address  ThisAddress
        End With
NextSheet:
    Next Ws
Finish:
    If Reply = vbYes Then
        Exit Sub
    Else
        FirstSheet.Select
        MsgBox "Search Completed - Sorry, no more " & Lost & "s", _
        vbInformation, "No Region Selected"
    End If
End Sub

any and all assistanace would be appreciated

Reply | Quote

Replies

Is your code visiting each match, i.e., can you just increment a counter, or do you want to stop at the first match and yet report the total number of matches? The latter probably requires a different approach, maybe a VBA equivalent to a COUNTIF function?

Reply | Quote

yes sir, I would like for it to show the first match then tell me how many are within that certain spreadsheet. My spreadsheets are named after the date MMMYYYY (Jul2010) etc…

P.s.

I’m sorry I did not respond any earlier but I was hospitalized. Thank you once again for any and all assistance.

I’m also having problems with my data not getting to my spreadsheet. I have attached a copy of what I have done so far. Please keep in mind I’m doing this from my school books. If you or anybody else can think of a better way to get this done please inform. I will take any and all assistance. But it has to be in visual basic and excel.

Thank you.

Reply | Quote

Here is a Function that takes a value you are searching for in your workbook as an argument and returns the number of the items that were found. You should be able to modify this to solve your problem.
It also does not change the current selection. In fact it doesn’t care what your selection is at all.

You can call it from the Immediate Window with a date:
? FindCellsWithValues(#7/1/10#)

It will search through all of the cells in every sheet in your Workbook that have values entered in them. It will ignore cells with Formulas and blank cells

Hope that points you in the right direction.

Bob Oxford

Code:

Option Explicit

Public Function FindCellsWithValues(varValue As Variant)
On Error GoTo Handle_Errors

Dim wrksht As Worksheet
Dim rng As Range
Dim intCounter As Integer
Dim rngCellPointer As Range

For Each wrksht In ThisWorkbook.Worksheets
    Set rng = wrksht.Range("a1").SpecialCells(xlCellTypeConstants, 23)
    If Not (rng Is Nothing) Then
        For Each rngCellPointer In rng.Cells
            If rngCellPointer.Value = varValue Then intCounter = intCounter + 1
        Next rngCellPointer
    End If
Set rng = Nothing
Next wrksht

Exit_Here:

Set rng = Nothing
Set rngCellPointer = Nothing
Set wrksht = Nothing
FindCellsWithValues = intCounter
Exit Function

Handle_Errors:

Select Case Err.Number

Case 1004 'DIdn't find any Cell is this Worksheet
    Resume Next
Case Else
    MsgBox Err.Number & ": " & Err.Description
    Resume Exit_Here

End Select
End Function

Reply | Quote