Create new worksheet based on text in coloured cells, and copy data into new worksheet

Question

I have a large data set which I need to manipulate and create individual worksheets. Within column B all cells which are coloured Green I would like to make a new worksheet for. Please see screen shot.

For example I would like to create worksheets titled "Shopping" & "Retail". Once the worksheet is created, I would then like to copy all the data between the "worksheet title" (Green Cells) from columns ("B:C") & ("AI:BH") Please see screen shot below for expected output;

The code I have so far is below as you can see it is not complete as I do not know how I would go about extracting data between the "Green Cells".

Sub wrksheetadd()

Dim r As Range
Dim i As Long
Dim LR As Long
Worksheets("RING Phased").Select

LR = Range("B65536").End(xlUp).Row
Set r = Range("B12:B" & (LR))

For i = r.Rows.Count To 1 Step -1
    With r.Cells(i, 1)
        If .DisplayFormat.Interior.ColorIndex = 35 Then
        MsgBox i
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells (i,1).Value
        Worksheets("RING Phased").Select
        End If
    End With
Next i

End Sub

Any help around this would be much appreciated.

Answer 1

Sorry for taking a while to get back to this, I've been somewhat busy the last few days, so I haven't had much time to be on StackOverflow.

Anyway, the way I'd go about this would be to store all the found values in an array, and then loop through that array in order to find the distance between them.

The following code works for me, using some very simplified data, but I think the principle is sound:

Option Explicit
Option Base 0

Sub wrksheetadd()

  Dim r As Range, c As Range
  Dim i As Long: i = 0
  Dim cells_with_color() As Range: ReDim cells_with_color(1)

  With Worksheets("RING Phased")
    ' Since it doesn't seem like the first cell you want to copy from is colored, hardcode that location here.
    ' This also saves us from having to test if the array is empty later.
    Set cells_with_color(i) = .Range("B12")
    i = i + 1
    Set r = Range(.Range("B13"), .Range("B" & .Cells.Rows.Count).End(xlUp))

    ' Put all the cells with color in the defined range into the array
    For Each c In r
      If c.DisplayFormat.Interior.ColorIndex = 35 Then
        If i > UBound(cells_with_color) Then
          ReDim Preserve cells_with_color(UBound(cells_with_color) + 1)
        End If
        Set cells_with_color(i) = c
        i = i + 1
      End If
    Next

    ' Loop through the array, and copy from the previous range value to the current one into a new worksheet
    ' Reset counter first, we start at 1, since the first range-value (0 in the array) is just the start of where we started checking from
    ' (Hmm, reusing variables may be bad practice >_>)
    i = 1
    While i <= UBound(cells_with_color)
      Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cells_with_color(i).Value
      ' Set the range to copy - we could just do this in the copy-statement, but hopefully this makes it slightly easier to read
      Set r = .Rows(CStr(cells_with_color(i - 1).Row) + 1 & ":" & CStr(cells_with_color(i).Row))
      ' Change the destination to whereever you want it on the new sheet. I think it has to be in column one, though, since we copy entire rows.
      ' If you want to refine it a bit, just change whatever you set r to in the previous statement.
      r.Copy Destination:=Worksheets(CStr(cells_with_color(i).Value)).Range("A1")
      i = i + 1
    Wend
  End With
End Sub

It probably lacks some error-checking which ought to be in there, but I'll leave that as an exercise to you to figure out. I believe it is functional. Good luck!