Count & Sum Consecutive (2x) appearance of Specific Numeric Values

[Sam via OfficeKB.com]

Hi All,

Can anyone offer a VBA solution:

I have a Named Range called "Data" that spans 8 columns and 7 rows. A Numeric
Value will appear only once in a row. Each row's Numeric Values are in
ascending order. Each Numeric Criteria to be counted will be listed in Column
"A" starting at Row "2" to Row "39".

How to Count the Consecutive (2x) appearance:
A consecutive value will be in the row below the original value and in any
column; i.e. Col1 Row5 = 101 & Col2 Row6 = 101. This is a count of 1
consecutive group of 2 for Numeric Value 101.

The results will be returned down Column "C" starting at Row "2" to Row "39".

Sample Data Layout:

101 102 107 129 145 370 490 501
101 106 107 128 129 430 470 580
101 129 140 150 350 430 460 470
100 102 129 130 149 330 440 470
101 108 120 129 200 280 430 535
100 101 170 175 176 280 420 520
121 189 170 202 229 230 420 521

Expected Results: (Times Numeric Vales appear in consecutive groups of 2)
Numeric Value 101 = 1
Numeric Value 107 = 1
Numeric Value 129 = 2
Numeric Value 170 = 1
Numeric Value 430 = 1
Numeric Value 280 = 1
Numeric Value 420 = 1

NB: Numeric Value 101 - Col 1 Rows 1,2,3 is a single consecutive count of 3.
Numeric Value 470 - Cols 7,8 Rows 2,3,4 is a single consecutive count of 3.

Thanks
Sam

 

[Tom Ogilvy]

101: Rows 1,2,3 4,5 should be two
129: Rows 1,2,3,4,5 should be one

anyway, this worked for me:

Sub CountData()
Dim rng As Range, rng1 As Range
Dim cnt As Range, cell As Range
Dim cell1 As Range, cnt1 As Long
Set rng = Range("Data")
Set rng1 = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cell In rng1
Set rng2 = Nothing
For Each cell1 In rng
If cell1 = cell Then
If rng2 Is Nothing Then
Set rng2 = Cells(cell1.Row, 1)
Else
Set rng2 = Union(rng2, Cells(cell1.Row, 1))
End If
End If
Next
cnt1 = 0
For Each ar In rng2.Areas
If ar.Count > 1 Then
cnt1 = cnt1 + 1
End If
Next
cell.Offset(0, 1).Value = cnt1
Next
End Sub

 

[Sam via OfficeKB.com]

Hi Tom,

Thank you very much indeed for your reply and assistance. Your VBA Code is in
essence what I'm looking for. Brilliant!

However, I think the phrasing of "my required Consecutive Count" was not
clear.

101: Rows 1,2,3 4,5 should be two

101: Rows 1,2,3 Should NOT be counted as I only want Numeric Values counted
whose consecutive appearance(s) are qualified by no more than one consecutive
appearance (per appearance) i.e; the original Numeric Value and then the
second instance.

129: Rows 1,2,3,4,5 should be one

129: Rows 1,2,3,4,5 Should NOT be counted - qualification reason as above.

Would be great if your VBA Code could reflect my required Consecutive Count?

Cheers,
Sam

anyway, this worked for me:

Sub CountData()

Dim rng As Range, rng1 As Range
Dim cnt As Range, cell As Range
Dim cell1 As Range, cnt1 As Long
Set rng = Range("Data")
Set rng1 = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cell In rng1
Set rng2 = Nothing
For Each cell1 In rng
If cell1 = cell Then
If rng2 Is Nothing Then
Set rng2 = Cells(cell1.Row, 1)
Else
Set rng2 = Union(rng2, Cells(cell1.Row, 1))
End If
End If
Next
cnt1 = 0
For Each ar In rng2.Areas
If ar.Count > 1 Then
cnt1 = cnt1 + 1
End If
Next
cell.Offset(0, 1).Value = cnt1 "changed Cell Offset to (0, 2)" for
column "C"
Next

 

[Tom Ogilvy]

I have no idea what you want. I am sure my code could be adapted to meet
your conditions but you haven't successfully communicated those to me at
least.

 

[Sam via OfficeKB.com]

Hi Tom,

In column one of the Original Sample Data Numeric Value 101 appears a total
of 3 times. My original text referred to that as 3 consecutive appearances.
Actually, to try and clarify, I should have said the original value and 2
consecutives.

The count that I require is the original Numeric Value and 1 consecutive
appearance: making a total count of 2 appearances, as per Numeric Value 101
in column one of the example immediately below. The Numeric Value should
only be counted if it has a consecutive count of 1, such as Numeric Value 101.


For example:
101 102 107 129 145 370 490 501
101 106 107 128 129 430 470 580
102 129 140 150 350 430 460 470
100 102 129 130 149 330 440 470

NB: In the above example Numeric Value 101 should be counted as it has an
explicit count of 2 appearances which equates to 1 consecutive count.

Numeric Value 101 in column one of the Orignal Sample Data should NOT be
counted. It appears 3 times. I'm looking for a count of an explicit
appearance of 2 times.

Original Sample Data Layout:

101 102 107 129 145 370 490 501
101 106 107 128 129 430 470 580
101 129 140 150 350 430 460 470
100 102 129 130 149 330 440 470
101 108 120 129 200 280 430 535
100 101 170 175 176 280 420 520
121 189 170 202 229 230 420 521

NB: Numeric Value 101 - Col 1 Rows 1,2,3 is a single consecutive count of 2.
Numeric Value 470 - Cols 7,8 Rows 2,3,4 is a single consecutive count of 2.


Expected Results: (Times Numeric Vales appear in groups of 2)
Numeric Value 101 = 1
Numeric Value 107 = 1
Numeric Value 129 = 2
Numeric Value 170 = 1
Numeric Value 430 = 1
Numeric Value 280 = 1
Numeric Value 420 = 1

NB: Numeric Value 101 - Col 1 Rows 1,2,3 is a single consecutive count of 2.
Numeric Value 470 - Cols 7,8 Rows 2,3,4 is a single consecutive count of 2.

How to Count the Consecutive (2x) appearance:
A consecutive value will be in the row below the original value and in any
column; i.e. Col1 Row5 = 101 & Col2 Row6 = 101. This is a count of 1
consecutive for Numeric Value 101.

Cheers,
Sam

 

[Tom Ogilvy]

Sub CountData()
Dim rng As Range, rng1 As Range
Dim cnt As Range, cell As Range
Dim cell1 As Range, cnt1 As Long
Set rng = Range("Data")
Set rng1 = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cell In rng1
Set rng2 = Nothing
For Each cell1 In rng
If cell1 = cell Then
If rng2 Is Nothing Then
Set rng2 = Cells(cell1.Row, 1)
Else
Set rng2 = Union(rng2, Cells(cell1.Row, 1))
End If
End If
Next
cnt1 = 0
For Each ar In rng2.Areas
If ar.Count = 2 Then
cnt1 = cnt1 + 1
End If
Next
cell.Offset(0, 1).Value = cnt1
Next
End Sub

Produces results matching yours except for 129.

this matches your results:

Sub CountData()
Dim rng As Range, rng1 As Range
Dim cnt As Range, cell As Range
Dim cell1 As Range, cnt1 As Long
Set rng = Range("Data")
Set rng1 = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cell In rng1
Set rng2 = Nothing
For Each cell1 In rng
If cell1 = cell Then
If rng2 Is Nothing Then
Set rng2 = Cells(cell1.Row, 1)
Else
Set rng2 = Union(rng2, Cells(cell1.Row, 1))
End If
End If
Next
cnt1 = 0
For Each ar In rng2.Areas
If ar.Count = 2 Then
cnt1 = cnt1 + 1
ElseIf ar.Count = 5 Then
cnt1 = cnt1 + 2
End If
Next
cell.Offset(0, 1).Value = cnt1
Next
End Sub

 

[Sam via OfficeKB.com]

Hi Tom,

Thank you very much for all your help and patience. Your VBA Code works
Brilliantly!

I've used the code with the heading "this matches your results" and amended 3
lines:

ElseIf ar.Count = 5 Then
cnt1 = cnt1 + 2
cell.Offset(0, 1).Value = cnt1

Now
ElseIf ar.Count > 2 Then
cnt1 = cnt1
cell.Offset(0, 2).Value = cnt1

this matches your results:
Sub CountData()

Dim rng As Range, rng1 As Range
Dim cnt As Range, cell As Range
Dim cell1 As Range, cnt1 As Long
Set rng = Range("Data")
Set rng1 = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cell In rng1
Set rng2 = Nothing
For Each cell1 In rng
If cell1 = cell Then
If rng2 Is Nothing Then
Set rng2 = Cells(cell1.Row, 1)
Else
Set rng2 = Union(rng2, Cells(cell1.Row, 1))
End If
End If
Next
cnt1 = 0
For Each ar In rng2.Areas
If ar.Count = 2 Then
cnt1 = cnt1 + 1
ElseIf ar.Count = 5 Then
cnt1 = cnt1 + 2
End If
Next
cell.Offset(0, 1).Value = cnt1
Next

End Sub

Your help is much appreciated.

Cheers,
Sam

 

[Sam via OfficeKB.com]

Hi Tom,

Apologies, no need for my amendment to

ElseIf ar.Count = 5 Then
cnt1 = cnt1 + 2

I should have used your first version of the code and not the version headed
up "this matches your results".

Cheers,
Sam

Tom Ogilvy wrote:
Sub CountData()

Dim rng As Range, rng1 As Range
Dim cnt As Range, cell As Range
Dim cell1 As Range, cnt1 As Long
Set rng = Range("Data")
Set rng1 = Range(Cells(2, 1), Cells(2, 1).End(xlDown))
For Each cell In rng1
Set rng2 = Nothing
For Each cell1 In rng
If cell1 = cell Then
If rng2 Is Nothing Then
Set rng2 = Cells(cell1.Row, 1)
Else
Set rng2 = Union(rng2, Cells(cell1.Row, 1))
End If
End If
Next
cnt1 = 0
For Each ar In rng2.Areas
If ar.Count = 2 Then
cnt1 = cnt1 + 1
End If
Next
cell.Offset(0, 1).Value = cnt1
Next

End Sub

Produces results matching yours except for 129.

29 is correct per your VBA code. My count was incorrect.