none
Find a range of same values in a column RRS feed

  • 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

    Wednesday, August 24, 2016 12:01 PM

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
    

    Wednesday, August 24, 2016 1:40 PM
  • 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
    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

    Best regards, George



    Wednesday, August 24, 2016 2:22 PM
  • 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.

    Thursday, August 25, 2016 6:09 PM
    Answerer

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
    

    Wednesday, August 24, 2016 1:40 PM
  • 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
    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

    Best regards, George



    Wednesday, August 24, 2016 2:22 PM
  • 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.

    Thursday, August 25, 2016 6:09 PM
    Answerer