Solved

Excel vba cut & paste rows based on interior cell color of column

Posted on 2011-03-24
10
990 Views
Last Modified: 2012-05-11
Hi! I have a worksheet "Open" that has cells in column J that are conditionally colored "vbYellow". I need to have the rows with the cells in col. J colored yellow to be moved to below the last line of data on sheet "Resolved". Is there a simple macro that can do this? Experts-Exchange-Resolved-Events.xlsm
0
Comment
Question by:McQMom
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 4
10 Comments
 
LVL 22

Expert Comment

by:rspahitz
ID: 35209374
Is this something you will be doing over and over?  If not, you don't need VBA.

To copy just the yellow cells, go to the top of the column of data and turn on filters.  Then select the filter button and choose "Filter by color" and pick yellow.

With this list, it's now easy to cut the pieces you want and go to the Resolved sheet and paste them at the end.
then go and turn off the filter to get the original data back.
0
 

Author Comment

by:McQMom
ID: 35209397
This is something we do every single day so I'm hoping to automate it.
0
 
LVL 22

Expert Comment

by:rspahitz
ID: 35209401
Correction, you can't cut and paste filtered data; you need to copy then paste and come back and delete the filtered rows.
0
MS Dynamics Made Instantly Simpler

Make Your Microsoft Dynamics Investment Count  & Drastically Decrease Training Time by Providing Intuitive Step-By-Step WalkThru Tutorials.

 
LVL 22

Expert Comment

by:rspahitz
ID: 35209410
Let me see about giving you a macro...
0
 

Author Comment

by:McQMom
ID: 35209463
That would be great. Thx
0
 
LVL 22

Expert Comment

by:rspahitz
ID: 35209740
Make a copy of your workbook then add this code to VB and run it to see if it gives you what you want.  I haven't fully tested it so let me know if you have any issues.
 
Sub MoveHilightedItems()
    Dim objStartCell As Range
    Dim iRow As Integer
    Dim iColumn As Integer
    
    Set objStartCell = ActiveCell
    
    Range("B1").Select
    
    Selection.AutoFilter
    Range("B1").End(xlDown).Select
    
    iRow = ActiveCell.Row
    iColumn = ActiveCell.Column
    
    ActiveSheet.Range("$A$1:$B$" & iRow).AutoFilter Field:=2, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
    Rows("1:" & iRow).Select
    Selection.Copy
    Sheets("Resolved").Select
    Range("A1").Select
    Selection.End(xlDown).Select
    iRow = ActiveCell.Row
    Cells(iRow + 1, 1).Select
    
    ActiveSheet.Paste
    Sheets("Open").Select
    Application.CutCopyMode = False
    Selection.Cut
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    
    objStartCell.Select
    Set objStartCell = Nothing
End Sub

Open in new window

0
 

Author Comment

by:McQMom
ID: 35209986
All it moved was the headers in row 1
0
 
LVL 22

Accepted Solution

by:
rspahitz earned 500 total points
ID: 35210712
Sorry...I forgot to check your original sheet.  It seems that the yellow is in column J, not column B

So here, with some minor adjustments to make it work a bit better, especially since I see you already have filters turned on.
 
Sub MoveHilightedItems()
    Dim objStartCell As Range
    Dim iRow As Integer
    Dim iColumn As Integer
    Dim iDestinationBlankRow As Integer
    
    Set objStartCell = ActiveCell
    
    Sheets("Resolved").Select
    ActiveSheet.Range("A1").Select
    ActiveSheet.Range("A1").End(xlDown).Select
    iDestinationBlankRow = ActiveCell.Row + 1
    Sheets("Open").Select
    
    Range("J1").Select
    
    'Selection.AutoFilter
    Range("J1").End(xlDown).Select
    
    iRow = ActiveCell.Row
    iColumn = ActiveCell.Column
    
    ActiveSheet.Range("$A$1:$J$" & iRow).AutoFilter Field:=10, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
    Rows("2:" & iRow).Select
    Selection.Copy
    Sheets("Resolved").Select
    ActiveSheet.Cells(iDestinationBlankRow, 1).Select
    
    ActiveSheet.Paste
    Sheets("Open").Select
    Application.CutCopyMode = False
    Selection.Cut
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("$A:$U").AutoFilter Field:=10

    If Not objStartCell Is Nothing Then
        On Error Resume Next
        objStartCell.Select
        Set objStartCell = Nothing
    End If
End Sub

Open in new window


You can add this directly to the code window for the Open tab.
0
 

Author Closing Comment

by:McQMom
ID: 35210751
That was perfect. Thank you so much!!!
0
 
LVL 22

Expert Comment

by:rspahitz
ID: 35210764
Whew!  Good :)

BTW I see that you have several different modules in VBA, each with one macro/procedure.  You can combine these into a single module unless you have a reason to keep them separate.  And unless you are specifically referencing a module (Module1.xxx) then a simple copy/paste/remove old module will do the trick.
enjoy!
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

734 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question