Count number of occurrences for a number of ranges from a find loop

**ANDREWA** · 08-15-2012, 07:46 AM

Hello, I need to display the number of occurrences for each range within an array and put this value offset to the range cell. I have attached an example workbook of what I need to happen. The Macro (See below) works fine, just need to figure out how to count how many of each it finds. Just cant get my head around it? My Vba is very basic, hope someone can help?

Option Explicit
Sub Mark_Cells_In_Column()
 Dim FirstAddress As String, I As Long
 Dim MyArr As Variant, Rng As Range, Sh As Worksheet

 Sheets("Sheet1").Select
 With Application
    .ScreenUpdating = False
    .EnableEvents = False
 End With
 MyArr = Array(Range("A4").Value, Range("A5").Value, Range("A6").Value, Range("A7").Value, Range("A8").Value, Range("A9").Value, Range("A10").Value, Range("A11").Value, Range("A12").Value, Range("A13").Value)
 For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> "Sheet1" Then
        With Sh.Range("A:A")
 '           .Offset(0, 1).ClearContents
            For I = LBound(MyArr) To UBound(MyArr)
            If MyArr(I) <> "" Then
                Set Rng = .Find(What:=MyArr(I), After:=.Cells(.Cells.Count), _
                    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False)
                If Not Rng Is Nothing Then
                    FirstAddress = Rng.Address
                    Do
                        Rng.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                        Rng.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                        Set Rng = .FindNext(Rng)
                    Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                End If
                End If
            Next I
        End With
    End If
 Next Sh
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

Thanks

**ANDREWA** · 08-15-2012, 07:47 AM

Sorry forgot to attach!!

**wallyeye** · 08-15-2012, 11:55 AM

A couple tweaks to your code:

Option Explicit
Sub Mark_Cells_In_Column()
 Dim Rng                As Excel.Range
 Dim Sh                 As Excel.Worksheet
 Dim rngBins            As Excel.Range

 Dim MyArr              As Variant

 Dim FirstAddress       As String
 Dim I                  As Long

 Sheets("Sheet1").Select
 With Application
    .ScreenUpdating = False
    .EnableEvents = False
 End With
 Set rngBins = Range("A4:B13")
 MyArr = rngBins.Value
 For I = LBound(MyArr) To UBound(MyArr)
    MyArr(I, 2) = 0
 Next I
 For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> "Sheet1" Then
        With Sh.Range("A:A")
 '           .Offset(0, 1).ClearContents
            For I = LBound(MyArr) To UBound(MyArr)
                If MyArr(I, 1) <> "" Then
                    Set Rng = .Find(What:=MyArr(I, 1), After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False)
                    If Not Rng Is Nothing Then
                        FirstAddress = Rng.Address
                        Do
                            MyArr(I, 2) = MyArr(I, 2) + 1
                            Rng.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                            Rng.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                            Set Rng = .FindNext(Rng)
                        Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                    End If
                End If
            Next I
        End With
    End If
 Next Sh
 For I = LBound(MyArr) To UBound(MyArr)
    If MyArr(I, 2) > 0 Then
        MyArr(I, 1) = "Found"
    Else
        MyArr(I, 1) = "Not Found"
    End If
 Next I
 rngBins.Offset(0, 1).Resize(rngBins.Rows.Count, 2) = MyArr

 Set Rng = Nothing
 Set rngBins = Nothing

 With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

I created a rngBins so I could refer to it later, and set it to the array of ranges you gave, with an extra column to store the totals. Then I set the totals to zero. Each item found increments the total for the given row. After all the sheets have been updated and accumulated, I go through the totals and use them to update column 1 of the array to Found/Not Found, and post it back to the worksheet using an offset to rngBins.

**ANDREWA** · 08-15-2012, 01:58 PM

Thanks Wallyeye, thats great, you make it seem so simple, would never have been able to do that, works perfectly.

Hopefully not pushing my luck but is it possible to record the sheet names that the array values were found in and list them on the same sheet? In the actual workbook each sheet name is the name of a project, approximately 250 sheets at the moment, would be handy if the user could see a list of the projects (sheetnames) that had been added too. Doesnt matter which range was found on which sheet, just a list of the sheets that the ranges were found on! That would really top things off.

**wallyeye** · 08-15-2012, 05:27 PM

A couple more tweaks:

Option Explicit
Sub Mark_Cells_In_Column()
 Dim Rng                As Excel.Range
 Dim Sh                 As Excel.Worksheet
 Dim rngBins            As Excel.Range

 Dim MyArr              As Variant
 Dim scpSheets          As Object

 Dim FirstAddress       As String
 Dim I                  As Long

 Sheets("Sheet1").Select
 With Application
    .ScreenUpdating = False
    .EnableEvents = False
 End With
 Set rngBins = Range("A4:B13")
 MyArr = rngBins.Value
 For I = LBound(MyArr) To UBound(MyArr)
    MyArr(I, 2) = 0
 Next I
 Set scpSheets = CreateObject("Scripting.Dictionary")
 scpSheets.CompareMode = 1
 For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> "Sheet1" Then
        With Sh.Range("A:A")
 '           .Offset(0, 1).ClearContents
            For I = LBound(MyArr) To UBound(MyArr)
                If MyArr(I, 1) <> "" Then
                    Set Rng = .Find(What:=MyArr(I, 1), After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False)
                    If Not Rng Is Nothing Then
                        FirstAddress = Rng.Address
                        If Not scpSheets.Exists(Sh.Name) Then
                            scpSheets.Item(Sh.Name) = Sh.Index
                        End If
                        Do
                            MyArr(I, 2) = MyArr(I, 2) + 1
                            Rng.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                            Rng.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                            Set Rng = .FindNext(Rng)
                        Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                    End If
                End If
            Next I
        End With
    End If
 Next Sh
 For I = LBound(MyArr) To UBound(MyArr)
    If MyArr(I, 2) > 0 Then
        MyArr(I, 1) = "Found"
    Else
        MyArr(I, 1) = "Not Found"
    End If
 Next I
 rngBins.Offset(0, 1).Resize(rngBins.Rows.Count, 2) = MyArr
 rngBins.Offset(rngBins.Rows.Count + 2, 0).Resize(scpSheets.Count, 1) _
    = Application.Transpose(scpSheets.Keys())

 Set Rng = Nothing
 Set rngBins = Nothing

 With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

This starts the list two rows down from the bottom of the Bin Numbers, you can place it wherever you want. The scripting dictionary is a pretty cool tool I had pointed out to me recently, it works well in this application.

**ANDREWA** · 08-16-2012, 05:36 AM

Wallyeye, I have another macro that runs on each worksheet when a cell is changed, but when this macro runs and adds the offset values to the sheet obviously the change macro does not activate. Is there a way to do this?

**mike7952** · 08-16-2012, 06:12 AM

Give this a try

Sub abc()
 Dim FoundCell As Range
 Dim LastCell As Range
 Dim FirstAddr As String
 Dim ws As Worksheet
 Dim a() As Variant
 Dim i As Long
 
    ReDim a(1 To 10, 1 To 3)
    a = Range("A4:C13")
    For i = 1 To UBound(a)
         a(i, 3) = 0
         a(i, 2) = "Not Found"
    Next
    For i = 1 To UBound(a)
        For Each ws In Worksheets
            If ws.Name <> "Sheet1" Then
                With ws.Range("A:A")
                    Set LastCell = .Cells(.Cells.Count)
                End With
                Set FoundCell = ws.Range("A:A").Find(What:=a(i, 1), After:=LastCell)

                If Not FoundCell Is Nothing Then
                    FirstAddr = FoundCell.Address
                End If
                
                Do Until FoundCell Is Nothing
                    a(i, 3) = a(i, 3) + 1
                    a(i, 2) = "Found"
                    FoundCell.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                    FoundCell.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                    Set FoundCell = ws.Range("A:A").FindNext(After:=FoundCell)
                    
                    If FoundCell.Address = FirstAddr Then
                        Exit Do
                    End If
                Loop
            End If
        Next
    Next
    Range("A4").Resize(10, 3) = a
    Erase a
    Set ws = Nothing
    Set FoundCell = Nothing
    Set LastCell = Nothing
End Sub

---------- Post added at 06:12 AM ---------- Previous post was at 06:11 AM ----------

Give this a try

Sub abc()
 Dim FoundCell As Range
 Dim LastCell As Range
 Dim FirstAddr As String
 Dim ws As Worksheet
 Dim a() As Variant
 Dim i As Long
 
    ReDim a(1 To 10, 1 To 3)
    a = Range("A4:C13")
    For i = 1 To UBound(a)
         a(i, 3) = 0
         a(i, 2) = "Not Found"
    Next
    For i = 1 To UBound(a)
        For Each ws In Worksheets
            If ws.Name <> "Sheet1" Then
                With ws.Range("A:A")
                    Set LastCell = .Cells(.Cells.Count)
                End With
                Set FoundCell = ws.Range("A:A").Find(What:=a(i, 1), After:=LastCell)

                If Not FoundCell Is Nothing Then
                    FirstAddr = FoundCell.Address
                End If
                
                Do Until FoundCell Is Nothing
                    a(i, 3) = a(i, 3) + 1
                    a(i, 2) = "Found"
                    FoundCell.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                    FoundCell.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                    Set FoundCell = ws.Range("A:A").FindNext(After:=FoundCell)
                    
                    If FoundCell.Address = FirstAddr Then
                        Exit Do
                    End If
                Loop
            End If
        Next
    Next
    Range("A4").Resize(10, 3) = a
    Erase a
    Set ws = Nothing
    Set FoundCell = Nothing
    Set LastCell = Nothing
End Sub

**ANDREWA** · 08-16-2012, 05:22 AM

Hey Wallyeye, That is pretty cool. Ive just noticed the code fails if it finds nothing, rather than just showing not found and 0 for all! Any Ideas?

**wallyeye** · 08-16-2012, 03:22 PM

Just a little tweak at the bottom:

 If scpSheets.Count > 0 Then
    rngBins.Offset(rngBins.Rows.Count + 2, 0).Resize(scpSheets.Count, 1) _
       = Application.Transpose(scpSheets.Keys())
 End If

For the macros, I would recommend changing the worksheet_change macro on each to point to a generic routine, passing the changed cell, something like:

Private Sub Worksheet_Change(Byval Target as Excel.Range)

    dim celCurr          as excel.range

    for each celcurr in target.cells
         call Generic_Change(celcurr)
    next celcurr

end sub

Then your Generic_Change (in a new module) would look something like this:

public Generic_Change(byval Target as excel.range)
.
.
.
end sub

You would just need to make sure you don't refer to the active worksheet, and keep all your range or cell references related to the target.worksheet, i.e. instead of:

Range("A4")

you would use:

Target.Parent.Range("A4")

This will allow the Generic_Change routine to work with any worksheet.

Then, from the current Mark_Cells_In_Column procedure, after you update rng.Offset(0,1).value, you could just call Generic_Change with the desired target:

                            Rng.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                            Rng.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                            Call Generic_Change(Rng.Offset(0,1))

This would manually trigger the worksheet_change event when you procedure updates the cells.

**ANDREWA** · 08-17-2012, 03:45 PM

Tweak works perfectly. Tried the rest, the generic routine works, so the code works as it did when it was running on the sheet, but only when i manually enter onto the sheet. When the cell values are added via running the Mark_cells_in_column macro it still doesnt seem to work, but does not errror! Its probably to do with my code?

Public Sub Generic_Change(ByVal Target As Range)

Dim NewText As String
Dim NewVal As Variant
Dim OldText As String
Dim OldVal As Variant

Dim single_cell As Range
Dim applicable_range As Range


On Error Resume Next
Set applicable_range = Intersect(Target, Range("A2:A11,B2:B11,C2:C11"))
On Error GoTo 0

If applicable_range Is Nothing Then Exit Sub

ActiveSheet.Unprotect Password:="AJA"

For Each single_cell In applicable_range.Cells
    If single_cell.Value <> "" Then
        
      
        NewVal = single_cell.Value
       
        
        If single_cell.Comment Is Nothing Then
            OldVal = "<nothing>"
        Else
            With single_cell.Comment
                OldVal = Mid(.Text, InStrRev(.Text, " to ") + 4)
                OldVal = Trim(Left(OldVal, InStrRev(OldVal, " by ")))
            End With
        End If

        NewText = "On " & Now() & " cell changed from " & OldVal _
        & " to " & NewVal & " by " & Environ("UserName")
        
        If single_cell.Comment Is Nothing Then
            single_cell.AddComment
        End If
        
        
        With single_cell.Comment
            .Shape.TextFrame.AutoSize = True
            OldText = .Text & vbLf
            .Text Text:=OldText & NewText
        End With
        
        
        single_cell.Locked = True
    End If
Next

ActiveSheet.Protect Password:="AJA"
End Sub

The sheets are protected, so this adds a comment and then locks the cell once a value is entered.
I have attached the previous workbook, with all code in as an example.
Thanks for all your help, its much appreciated.

**wallyeye** · 08-17-2012, 06:12 PM

Sooo close. Generic_Change can be processed against any of the worksheets, so we need to be specific which worksheet we are referring to:

Public Sub Generic_Change(ByVal Target As Range)

Dim NewText As String
Dim NewVal As Variant
Dim OldText As String
Dim OldVal As Variant

Dim single_cell As Range
Dim applicable_range As Range


On Error Resume Next
Set applicable_range = Intersect(Target, Target.Parent.Range("A2:A11,B2:B11,C2:C11"))
On Error GoTo 0

If applicable_range Is Nothing Then Exit Sub

Target.Parent.Unprotect Password:="AJA"

For Each single_cell In applicable_range.Cells
    If single_cell.Value <> "" Then
        
      
        NewVal = single_cell.Value
       
        
        If single_cell.Comment Is Nothing Then
            OldVal = "<nothing>"
        Else
            With single_cell.Comment
                OldVal = Mid(.Text, InStrRev(.Text, " to ") + 4)
                OldVal = Trim(Left(OldVal, InStrRev(OldVal, " by ")))
            End With
        End If

        NewText = "On " & Now() & " cell changed from " & OldVal _
        & " to " & NewVal & " by " & Environ("UserName")
        
        If single_cell.Comment Is Nothing Then
            single_cell.AddComment
        End If
        
        
        With single_cell.Comment
            .Shape.TextFrame.AutoSize = True
            OldText = .Text & vbLf
            .Text Text:=OldText & NewText
        End With
        
        
        single_cell.Locked = True
    End If
Next

Target.Parent.Protect Password:="AJA"
End Sub

Here I've changed both of the protect lines to work on Target.Parent, replacing ActiveSheet. Then, for setting applicable_range, we need to look at Target.Parent.Range, to specifically get the Target's worksheet. "Range" by itself will refer to the ActiveSheet.

**ANDREWA** · 08-18-2012, 03:19 PM

Bingo

Wallyeye, you have been a great help, thanks for everything, a true excel guru. I think its safe to save this post is well and truly solved.
Thanks again

**wallyeye** · 08-23-2012, 07:53 PM

Glad to be of help!

Count number of occurrences for a number of ranges from a find loop

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Re: Count number of occurrences for a number of ranges from a find loop

Thread Information

Users Browsing this Thread

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions