Splitting a range into to 2 ranges based on values from another range RRS feed

  • Question

  • I've come up with two ways of solving my problem:

    1)Split the range B2 to B26  based on whether the cell next to it is either High or Low

    2) Loop through range C2 to C26 and check if either high or low. If High then go to cell on left and add that cell (say B2) to a new range ("HighRange") - PReferred choice

    i know how to loop through cells but how do I check if cell value is the string "High" and crucially then go to cell to immediate left and then add that cell to new range?

    Help would be appreciated


    • Edited by VBNovice01 Tuesday, January 10, 2017 10:56 AM
    Tuesday, January 10, 2017 10:56 AM

All replies

  • Option Explicit
    Sub Test()
      Dim R As Range
      'Find all "High" in column C
      Set R = FindAll(Range("C:C"), "High")
      If R Is Nothing Then
        Exit Sub
        'One column to the left
        Set R = R.Offset(, -1)
        'Name that cells
        R.Name = "HighRange"
      End If
    End Sub
    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
        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)
          If SearchDirection = xlNext Then
            Set c = Where.FindNext(c)
            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
      'Combine each fragment with the next one
      j = 1
        For i = 0 To UBound(Temp) - j Step j * 2
          Set Temp(i) = Union(Temp(i), Temp(i + j))
        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

    Tuesday, January 10, 2017 11:12 AM