Excel Challenge: Macro based on cells background color - cut/paste and copy down

[lost_in_macros]

Hi awesome Mr. Excel community!

I am currently trying to create a rather complicated macro, and as you might have guessed by my user name, I am a bit lost right now.

This is how my data is currently shaped: I have one column which contains the data of owners (turquoise background, bgcolor=#CCFFFF or color=34 ) and tasks (white background). The number of owners, and the number of tasks per owner varies.

	A	B
1	Owner	Task
2		Anna (turquoise background)
4		Task 1 (white background)
5		Task 2 (white background)
6		Lisa (turquoise background)
7		Task 3 (white background)
8		Task 4 (white background)

<tbody>
</tbody>

This is how I want my data to look like:

	A	C
1	Owner	Task
2	Anna	Task 1
3	Anna	Task 2
4	Lisa	Task 3
5	Lisa	Task 4

<tbody>
</tbody>

What I want my Macro to do:

Cut all turquoise cells in column B and paste them into column A (two columns to the left). Then, starting from the first filled cell in column A, I want my macro to copy this cell into the empty cells in the rows below until it reaches the next filled cell. Then, I want it to go down one cell, copy this new cell and paste it into all the empty cells below until it gets to the next filled cell. I want this to happen until it reaches the end of the data (so some sort of if...then copy..until..then go down one..then loop construction). In the end, I would like every row with an empty cell in B to be deleted.

I know this is quite a complicated request, so all suggestions are welcome! Please reach out to me if you have any additional questions, and have a great day!

 

[RickXL]

Hi and welcome to the MrExcel Message Board.



If you want a macro solution you could try this:

Sub Rearrange()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim iRow As Long, rowOut As Long
    Dim Owner As String
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    'ws2.Cells.Clear
    
    With ws1
        ws2.Range("A1:B1").Value = .Range("A1:B1").Value
        rowOut = 2
        For iRow = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
            If .Cells(iRow, "B").Interior.Color = RGB(255, 255, 255) Then
                ws2.Cells(rowOut, "B").Value = .Cells(iRow, "B").Value
                ws2.Cells(rowOut, "A").Value = Owner
                rowOut = rowOut + 1
            Else
                Owner = .Cells(iRow, "B").Value
            End If
        Next   
    End With

End Sub

It needs to be pasted into a new Module in the Excel VB Editor.

Basically, it looks for white cells in column B. If it finds one it adds it to column B on Sheet2. If it finds a different colour then it assumes it is an owner so should be put into column A.

I have left in the statement that could clear sheet2. The initial single quote needs to be removed to make it active. (I am not sure if you will need that.)

 

[lost_in_macros]

Thank you so much for this macro, RickXL! This is helping me progress a lot faster. I am currently busy trying to include a third row with projects, so that for each entry I have the owner, the project and the task. I will let you know how it goes, or I might come back with another question.

Thanks for the quick response!

 

[Rick Rothstein]

Here is another macro for you to consider...

Sub MoveNamesAssociateWithTasks()
  Dim Cell As Range, FirstAddress As String
  Application.FindFormat.Clear
  Application.FindFormat.Interior.ColorIndex = 34
  With Range("B2", Cells(Rows.Count, "B").End(xlUp))
    Set Cell = .Find("", SearchFormat:=True)
    If Not Cell Is Nothing Then
      FirstAddress = Cell.Address
      Do
        Cell.Copy Cell.Offset(, -1)
        Cell.Clear
        Set Cell = .Find("", Cell, SearchFormat:=True)
      Loop While Not Cell Is Nothing
    End If
    .Offset(, -1).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Offset(, -1).Value = .Offset(, -1).Value
    .SpecialCells(xlBlanks).EntireRow.Delete
  End With
End Sub

 

[lost_in_macros]

Hi Rick,

thank you so much! I am busy trying to incorporate a third component (projects, background color is bgcolor=#666699 color=47) as part of this reshaping effort es well. I will walk through your macro, and might come back with some questions. Thank you so much for your help so far!

	A	B	C
1	Owner	Project	Task
2			Anna (turquoise background)
3			Project 1 (purple background)
4			Task 1 (white background)
5			Task 2 (white background)
6			Lisa (turquoise background)
7			Project 2 (purple background)
8			Task 3 (white background)
9			Task 4 (white background)

<tbody>
</tbody>

	A	B	C
1	Owner	Project	Task
2	Anna	Project 1	Task 1
3	Anna	Project 1	Task 2
4	Lisa	Project 2	Task 3
5	Lisa	Project 2	Task 4

<tbody>
</tbody>

 

[Rick Rothstein]

Please, in the future, do not simplify your question for us... ask your full question the first time. Otherwise you just make more work for the volunteers you are asking to help you (we have to set up a test worksheet, write the code, test it, post it, only to have throw it all out and start over again when you come back and tell us the real question you have).

Give this macro a try...

Sub MoveNamesAssociateWithTasks()
  Dim X As Long, Cell As Range, FirstAddress As String, V As Variant
  Application.FindFormat.Clear
  With Range("C2", Cells(Rows.Count, "C").End(xlUp))
    For X = 1 To 2
      Application.FindFormat.Interior.ColorIndex = Split("34 47")(X - 1)
      Set Cell = .Find("", SearchFormat:=True)
      If Not Cell Is Nothing Then
        FirstAddress = Cell.Address
        Do
          Cell.Copy Cell.Offset(2 - X, X - 3)
          Cell.Clear
          Set Cell = .Find("", Cell, SearchFormat:=True)
        Loop While Not Cell Is Nothing
      End If
    Next
    With Intersect(.SpecialCells(xlConstants).EntireRow, Columns("A:B"))
      .FormulaR1C1 = "=R[-1]C"
    End With
    .Offset(, -2).Resize(, 2).Value = .Offset(, -2).Resize(, 2).Value
    .SpecialCells(xlBlanks).EntireRow.Delete
  End With
End Sub

 

[lost_in_macros]

Hi Rick,

I am sorry if this created confusion, thanks for clarifying Forum rules. Thank you for this code, it works great for the project section! It does not copy down the Owner name correctly though. I am not sure if I understand it correctly, but it seems that it goes off the task cell and then copies the owner cell that it can find in the row above. This is what I see

1. visible step in Macro: copies purple and turqoise cells

	A	B	C
1	Owner	Project	Task
2	Lisa	Project 1
3		Project 2
4			Task 1
5			Task 2

<tbody>
</tbody>

2. visible step: copies down Owner and Project

	A	B	C
1	Owner	Project	Task
2	Lisa	Project 1
3		Project 2
4	0	Project 2	Task 1
5	0	Project 2	Task 2

<tbody>
</tbody>

It would be great to get to this outcome:

	A	B	C
1	Owner	Project	Task
2	Lisa	Project 1
3	Lisa	Project 2
4	Lisa	Project 2	Task 1
5	Lisa	Project 2	Task 2

<tbody>
</tbody>

Thank you for the time and effort you already put into this, I really appreciate it, and I hope I am not asking too much.

 

[Rick Rothstein]

Thank you for this code, it works great for the project section! It does not copy down the Owner name correctly though

I test the code before I posted it and I tested it again just now... it works correctly for me. Is your layout exactly like you showed in Message #5 with the owner cell's ColorIndex equal to 34 and the project cell's ColorIndex equal to 47?

 

[lost_in_macros]

Hi Rick,

it is, but what it doesn't show is that one person might have several projects assigned to them, and it won't say the person's name in the row above every project. It might be that e.g. Lisa has 5-10 projects assigned to her, and each project has any given number of tasks.

I am sorry for the inconvenience this is causing, please let me know if there is any additional information that you need. Thank you very much!

 

[Rick Rothstein]

Hi Rick,

it is, but what it doesn't show is that one person might have several projects assigned to them, and it won't say the person's name in the row above every project. It might be that e.g. Lisa has 5-10 projects assigned to her, and each project has any given number of tasks.

Sorry, I had misunderstood your data layout. Give this macro a try...

Sub MoveNamesAssociateWithTasks()
  Dim X As Long, Cell As Range, FirstAddress As String, V As Variant
  Application.FindFormat.Clear
  With Range("C2", Cells(Rows.Count, "C").End(xlUp))
    For X = 1 To 2
      Application.FindFormat.Interior.ColorIndex = Split("34 47")(X - 1)
      Set Cell = .Find("", SearchFormat:=True)
      If Not Cell Is Nothing Then
        FirstAddress = Cell.Address
        Do
          Cell.Copy Cell.Offset(2 - X, X - 3)
          Cell.Clear
          Set Cell = .Find("", Cell, SearchFormat:=True)
        Loop While Not Cell Is Nothing
      End If
    Next
    .Offset(, -2).Resize(, 2).SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Offset(, -2).Resize(, 2).Value = .Offset(, -2).Resize(, 2).Value
    .SpecialCells(xlBlanks).EntireRow.Delete
  End With
End Sub