Answered by:
Find a range of same values in a column
Question

I need to write a macro that will find the cell range based on a value. I need to find out what is the first and the last row that has the same value in a column. However, the problem is that there might two or even few ranges of the same value, because range of the other value might be in between (and I cannot sort values in a column, because it is time based output).
There are values in Column B (It could an infinitive number of rows). I need to write a macro that for example finds the range of cells with value 5. In this case B1:B7 and B15:B20. Conjunction of these two ranges will be later used as a range to generate the histogram.
This is the code that I wrote so far. The problem is that is takes whole range from B1 to B10 when criteria is value "5" and does not exclude the range where value is "10" (range B8:B14).
Private Sub HistogramButton_Click() Dim ProdNoValue As Integer Dim VisStartRow As Long Dim ActualStartRow As Long Dim VisEndRow As Long Dim ActualEndRow As Long Dim i As Integer Dim AllVisibleCells As Range Dim Rng As Range Dim Output As Range Dim MinVal As Double Dim MaxVal As Double Dim MinValF As Double Dim MaxValF As Double If ProdNoList.ListIndex = 1 Then MsgBox ("Please select product number first") Exit Sub Else ProdNoValue = ProdNoList.Value '< This is where match criteria is defined by means of UserForm (as in the example it could by a value of 5) End If Set Output = ThisWorkbook.Worksheets("Sheet2").Range("E2") Set AllVisibleCells = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible) VisStartRow = Application.WorksheetFunction.Match(ProdNoValue, AllVisibleCells, 0) ActualStartRow = AllVisibleCells.Row + VisStartRow  1 VisEndRow = Application.WorksheetFunction.CountIf(AllVisibleCells, ProdNoValue) ActualEndRow = ActualStartRow + VisEndRow  1 Set Rng = ActiveSheet.Range(Range("E" & ActualStartRow), Range("E" & ActualEndRow)) '< I will use values for further calculation from Column E MinVal = Application.WorksheetFunction.Min(Rng) MinValF = (Application.WorksheetFunction.RoundDown((MinVal / 5), 0)) * 5 MaxVal = Application.WorksheetFunction.Max(Rng) MaxValF = (Application.WorksheetFunction.RoundUp((MaxVal / 5), 0)) * 5 ThisWorkbook.Worksheets("Sheet2").Range("D1") = MinValF For i = 1 To 10 ThisWorkbook.Worksheets("Sheet2").Range("D" & i + 1) = ThisWorkbook.Worksheets("Sheet2").Range("D" & i).Value + ((MaxValF  MinValF) / 10) Next i Application.Run "ATPVBAEN.XLAM!Histogram", Rng, Output, ThisWorkbook.Worksheets("Sheet2").Range("D1:D11"), False, False, False, False End Sub
Answers

Option Explicit Private Sub HistogramButton_Click() Dim MinVal As Double Dim MaxVal As Double Dim MinValF As Double Dim MaxValF As Double Dim ProdNoValue As Variant Dim B As Range, E As Range, D As Range, This As Range, Last As Range 'Check the ProdNo If ProdNoList.ListIndex = 1 Then MsgBox "Please select product number first", vbExclamation Exit Sub End If ProdNoValue = ProdNoList.Value 'Find all occurences in column B Set B = FindAll(Columns("B"), ProdNoValue) If B Is Nothing Then MsgBox ProdNoValue & "not found", vbInformation Exit Sub End If 'Map this rows to column E Set E = Intersect(B.EntireRow, Columns("E")) 'Get the min/max values With WorksheetFunction MinVal = .Min(E) MinValF = .RoundDown(MinVal / 5, 0) * 5 MaxVal = .Max(E) MaxValF = .RoundUp(MaxVal / 5, 0) * 5 End With 'Map this rows to column D Set D = Intersect(B.EntireRow, Columns("D")) 'Fill each cell, increment from the last one For Each This In D If Last Is Nothing Then This = MinValF Else This = Last + CDbl((MaxValF  MinValF) / 10) End If Set Last = This Next 'Expand to the whole range (ATPVBAEN.XLAM!Histogram does not support areas!) Set B = Range("B1", Range("B" & Rows.Count).End(xlUp)) Set D = Intersect(B.EntireRow, Columns("D")) Set E = Intersect(B.EntireRow, Columns("E")) Application.Run "ATPVBAEN.XLAM!Histogram", B, E.Cells(1, 1), D, False, False, False, False End Sub Private Function FindAll(ByVal Where As Range, ByVal What, _ Optional ByVal After As Variant, _ Optional ByVal LookIn As XlFindLookIn = xlValues, _ Optional ByVal LookAt As XlLookAt = xlWhole, _ Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _ Optional ByVal SearchDirection As XlSearchDirection = xlNext, _ Optional ByVal MatchCase As Boolean = False, _ Optional ByVal SearchFormat As Boolean = False) As Range 'Find all occurrences of What in Where (Windows version) Dim FirstAddress As String Dim c As Range 'From FastUnion: Dim Stack As New Collection Dim Temp() As Range, Item Dim i As Long, j As Long If Where Is Nothing Then Exit Function If SearchDirection = xlNext And IsMissing(After) Then 'Set After to the last cell in Where to return the first cell in Where in front if _ it match What Set c = Where.Areas(Where.Areas.Count) 'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet 'Set After = C.Cells(C.Cells.Count) Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count)) End If Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat:=SearchFormat) If c Is Nothing Then Exit Function FirstAddress = c.Address Do Stack.Add c If SearchFormat Then 'If you call this function from an UDF and _ you find only the first cell use this instead Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat:=SearchFormat) Else If SearchDirection = xlNext Then Set c = Where.FindNext(c) Else Set c = Where.FindPrevious(c) End If End If 'Can happen if we have merged cells If c Is Nothing Then Exit Do Loop Until FirstAddress = c.Address 'FastUnion algorithm © Andreas Killer, 2011: 'Get all cells as fragments ReDim Temp(0 To Stack.Count  1) i = 0 For Each Item In Stack Set Temp(i) = Item i = i + 1 Next 'Combine each fragment with the next one j = 1 Do For i = 0 To UBound(Temp)  j Step j * 2 Set Temp(i) = Union(Temp(i), Temp(i + j)) Next j = j * 2 Loop Until j > UBound(Temp) 'At this point we have all cells in the first fragment Set FindAll = Temp(0) End Function
 Proposed as answer by Edward8520Microsoft contingent staff Thursday, August 25, 2016 2:34 AM
 Marked as answer by Edward8520Microsoft contingent staff Monday, September 5, 2016 7:43 AM

Here is a different and simpler approach if you can use that. It return an array with count of all cells with the same value:
Option Explicit
Best regards, George
Const COLUMN = "B" 'Adapt as needed
Sub test()
Dim r() As Integer
Dim i As Integer
Dim n As Integer
r = FindSameValues(COLUMN)
n = UBound(r)
For i = 1 To n
If r(i) > 0 Then Debug.Print "Number of cells with value " & i & " = " & r(i)
Next i
End Sub
'********************************************************
'* Return an array of count of same values in a column
'*
Function FindSameValues(col As String) As Integer()
Dim n As Integer
Dim row As Range
Dim r() As Integer
Dim maxIndex As Integer
maxIndex = 0
Set row = Range(col & 1)
While (row.Value <> "")
n = row.Value
If n > maxIndex Then
ReDim Preserve r(n)
maxIndex = n
End If
r(n) = r(n) + 1
Set row = row.Offset(1, 0) 'Next row
Wend
FindSameValues = r
End Function
 Edited by George.B.Summers Wednesday, August 24, 2016 2:28 PM
 Proposed as answer by Edward8520Microsoft contingent staff Thursday, August 25, 2016 2:34 AM
 Marked as answer by Edward8520Microsoft contingent staff Monday, September 5, 2016 7:43 AM

A bit differently. See if it works..
Sub FindAll() 'Assumed the value is long. You can change 'to string if required Dim i As Long Dim rSearch As Range Dim s As String 'Assumed entire B. You can change it if required. Set rSearch = Application.Intersect(ActiveSheet.UsedRange, Range("b:b")) i = Application.InputBox(Prompt:="Pls put criteria value", Type:=1) rSearch.Copy 'Creates a mirror workbook Workbooks.Add 'paste the data as mirror image ActiveSheet.Range(rSearch(1).Address).PasteSpecial xlPasteAll Application.CutCopyMode = False Set rSearch = ActiveSheet.UsedRange 'replacing in mirror workbook rSearch.Replace what:=i, replacement:="", lookat:=xlWhole On Error Resume Next s = rSearch.SpecialCells(xlCellTypeBlanks).Address If Err > 0 Then s = "Not found" ActiveWorkbook.Close False MsgBox s End Sub
Best Regards,
Asadulla Javed, Kolkata

Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue. Proposed as answer by Edward8520Microsoft contingent staff Tuesday, August 30, 2016 8:48 AM
 Marked as answer by Edward8520Microsoft contingent staff Monday, September 5, 2016 7:43 AM
All replies

Option Explicit Private Sub HistogramButton_Click() Dim MinVal As Double Dim MaxVal As Double Dim MinValF As Double Dim MaxValF As Double Dim ProdNoValue As Variant Dim B As Range, E As Range, D As Range, This As Range, Last As Range 'Check the ProdNo If ProdNoList.ListIndex = 1 Then MsgBox "Please select product number first", vbExclamation Exit Sub End If ProdNoValue = ProdNoList.Value 'Find all occurences in column B Set B = FindAll(Columns("B"), ProdNoValue) If B Is Nothing Then MsgBox ProdNoValue & "not found", vbInformation Exit Sub End If 'Map this rows to column E Set E = Intersect(B.EntireRow, Columns("E")) 'Get the min/max values With WorksheetFunction MinVal = .Min(E) MinValF = .RoundDown(MinVal / 5, 0) * 5 MaxVal = .Max(E) MaxValF = .RoundUp(MaxVal / 5, 0) * 5 End With 'Map this rows to column D Set D = Intersect(B.EntireRow, Columns("D")) 'Fill each cell, increment from the last one For Each This In D If Last Is Nothing Then This = MinValF Else This = Last + CDbl((MaxValF  MinValF) / 10) End If Set Last = This Next 'Expand to the whole range (ATPVBAEN.XLAM!Histogram does not support areas!) Set B = Range("B1", Range("B" & Rows.Count).End(xlUp)) Set D = Intersect(B.EntireRow, Columns("D")) Set E = Intersect(B.EntireRow, Columns("E")) Application.Run "ATPVBAEN.XLAM!Histogram", B, E.Cells(1, 1), D, False, False, False, False End Sub Private Function FindAll(ByVal Where As Range, ByVal What, _ Optional ByVal After As Variant, _ Optional ByVal LookIn As XlFindLookIn = xlValues, _ Optional ByVal LookAt As XlLookAt = xlWhole, _ Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _ Optional ByVal SearchDirection As XlSearchDirection = xlNext, _ Optional ByVal MatchCase As Boolean = False, _ Optional ByVal SearchFormat As Boolean = False) As Range 'Find all occurrences of What in Where (Windows version) Dim FirstAddress As String Dim c As Range 'From FastUnion: Dim Stack As New Collection Dim Temp() As Range, Item Dim i As Long, j As Long If Where Is Nothing Then Exit Function If SearchDirection = xlNext And IsMissing(After) Then 'Set After to the last cell in Where to return the first cell in Where in front if _ it match What Set c = Where.Areas(Where.Areas.Count) 'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet 'Set After = C.Cells(C.Cells.Count) Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count)) End If Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat:=SearchFormat) If c Is Nothing Then Exit Function FirstAddress = c.Address Do Stack.Add c If SearchFormat Then 'If you call this function from an UDF and _ you find only the first cell use this instead Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _ SearchDirection, MatchCase, SearchFormat:=SearchFormat) Else If SearchDirection = xlNext Then Set c = Where.FindNext(c) Else Set c = Where.FindPrevious(c) End If End If 'Can happen if we have merged cells If c Is Nothing Then Exit Do Loop Until FirstAddress = c.Address 'FastUnion algorithm © Andreas Killer, 2011: 'Get all cells as fragments ReDim Temp(0 To Stack.Count  1) i = 0 For Each Item In Stack Set Temp(i) = Item i = i + 1 Next 'Combine each fragment with the next one j = 1 Do For i = 0 To UBound(Temp)  j Step j * 2 Set Temp(i) = Union(Temp(i), Temp(i + j)) Next j = j * 2 Loop Until j > UBound(Temp) 'At this point we have all cells in the first fragment Set FindAll = Temp(0) End Function
 Proposed as answer by Edward8520Microsoft contingent staff Thursday, August 25, 2016 2:34 AM
 Marked as answer by Edward8520Microsoft contingent staff Monday, September 5, 2016 7:43 AM

Here is a different and simpler approach if you can use that. It return an array with count of all cells with the same value:
Option Explicit
Best regards, George
Const COLUMN = "B" 'Adapt as needed
Sub test()
Dim r() As Integer
Dim i As Integer
Dim n As Integer
r = FindSameValues(COLUMN)
n = UBound(r)
For i = 1 To n
If r(i) > 0 Then Debug.Print "Number of cells with value " & i & " = " & r(i)
Next i
End Sub
'********************************************************
'* Return an array of count of same values in a column
'*
Function FindSameValues(col As String) As Integer()
Dim n As Integer
Dim row As Range
Dim r() As Integer
Dim maxIndex As Integer
maxIndex = 0
Set row = Range(col & 1)
While (row.Value <> "")
n = row.Value
If n > maxIndex Then
ReDim Preserve r(n)
maxIndex = n
End If
r(n) = r(n) + 1
Set row = row.Offset(1, 0) 'Next row
Wend
FindSameValues = r
End Function
 Edited by George.B.Summers Wednesday, August 24, 2016 2:28 PM
 Proposed as answer by Edward8520Microsoft contingent staff Thursday, August 25, 2016 2:34 AM
 Marked as answer by Edward8520Microsoft contingent staff Monday, September 5, 2016 7:43 AM

A bit differently. See if it works..
Sub FindAll() 'Assumed the value is long. You can change 'to string if required Dim i As Long Dim rSearch As Range Dim s As String 'Assumed entire B. You can change it if required. Set rSearch = Application.Intersect(ActiveSheet.UsedRange, Range("b:b")) i = Application.InputBox(Prompt:="Pls put criteria value", Type:=1) rSearch.Copy 'Creates a mirror workbook Workbooks.Add 'paste the data as mirror image ActiveSheet.Range(rSearch(1).Address).PasteSpecial xlPasteAll Application.CutCopyMode = False Set rSearch = ActiveSheet.UsedRange 'replacing in mirror workbook rSearch.Replace what:=i, replacement:="", lookat:=xlWhole On Error Resume Next s = rSearch.SpecialCells(xlCellTypeBlanks).Address If Err > 0 Then s = "Not found" ActiveWorkbook.Close False MsgBox s End Sub
Best Regards,
Asadulla Javed, Kolkata

Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue. Proposed as answer by Edward8520Microsoft contingent staff Tuesday, August 30, 2016 8:48 AM
 Marked as answer by Edward8520Microsoft contingent staff Monday, September 5, 2016 7:43 AM