Results 1 to 4 of 4
  1. #1
    2 Star Lounger
    Join Date
    Feb 2008
    Location
    LOUISVILLE, Kentucky, USA
    Posts
    106
    Thanks
    0
    Thanked 0 Times in 0 Posts
    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

  2. Get our unique weekly Newsletter with tips and techniques, how to's and critical updates on Windows 7, Windows 8, Windows XP, Firefox, Internet Explorer, Google, etc. Join our 480,000 subscribers!

    Excel 2013: The Missing Manual

    + Get this BONUS — free!

    Get the most of Excel! Learn about new features, basics of creating a new spreadsheet and using the infamous Ribbon in the first chapter of Excel 2013: The Missing Manual - Subscribe and download Chapter 1 for free!

  3. #2
    Super Moderator jscher2000's Avatar
    Join Date
    Feb 2001
    Location
    Silicon Valley, USA
    Posts
    23,112
    Thanks
    5
    Thanked 93 Times in 89 Posts
    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?

  4. #3
    2 Star Lounger
    Join Date
    Apr 2004
    Posts
    129
    Thanks
    0
    Thanked 0 Times in 0 Posts
    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.
    Attached Files Attached Files

  5. #4
    Lounger
    Join Date
    Jun 2010
    Location
    Manchester, NH
    Posts
    34
    Thanks
    0
    Thanked 0 Times in 0 Posts
    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
    Bob Oxford
    Software Wizards, Inc.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •