PDA

View Full Version : Copy row to a new sheet if a cell in the row meets criteria



lebowski
01-10-2015, 04:46 AM
Hi, I am at a loss as to how to do the following in VBA:

I want to copy all rows from the current worksheet to a new worksheet (created and named by the script) if the cell in column W has a red (255, 0, 0) background.

Is anyone able to help? Thanks.

YasserKhalil
01-10-2015, 05:30 PM
May be something like that

Sub Test()
Dim Cell As Range
Dim WS As Worksheet
Dim LR As Long
Application.ScreenUpdating = False
For Each WS In Worksheets
Application.DisplayAlerts = False
If WS.Name = "Result" Then WS.Delete
Application.DisplayAlerts = True
Next WS

Worksheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Result"
Sheets("Sheet1").Activate

For Each Cell In Range("W1:W20")
If Cell.Interior.Color = RGB(255, 0, 0) Then
Cell.EntireRow.Copy
LR = Sheets("Result").Range("A" & Rows.Count).End(xlUp).Row + 1
If IsEmpty(Sheets("Result").Range("A1")) Then Sheets("Result").Range("A1").PasteSpecial xlPasteAll: GoTo 1
Sheets("Result").Range("A" & LR).PasteSpecial xlPasteAll
End If
1 Next Cell
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

lebowski
01-11-2015, 04:06 AM
Fantastic, works perfectly. Thank you so much.

YasserKhalil
01-11-2015, 05:51 AM
You're welcome . thanks for the feedback

SamT
01-11-2015, 09:44 AM
Lebowski, Here's another way to look at YasserKhalil's fine code. The main difference is the use of a ColorIndex, which does not change, although the color of that index can easily be changed on the Color Tab of the Tools >> Options menu. The Default value of Interior.ColorIndex(3) is RGB(255, 0, 0), as is the Constant vbRed. The other minor changes are mostly due to personal style preferences.


Sub Test()
Dim Cel As Range
Dim PasteHere As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False

OnError ResumeNext
Worksheets("Result").Delete

Worksheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Result"

For Each Cel In Sheets("Sheet1").UsedRange.Columns("W")
If Cel.Interior.ColorIndex = 3 Then
Cel.EntireRow.Copy
Set PasteHere = Sheets("Result").Range("A" & Rows.Count).End(xlUp)
If PasteHere.Row = 1 Then
PasteHere.PasteSpecial.xlPasteAll
Else
PasteHere.Offset(1, 0).PasteSpecial.xlPasteAll
End If
End If
Next Cel
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Run the TestColors Macro in this book

YasserKhalil
01-11-2015, 11:51 AM
Mr. SamT
Thanks for the modifications ... You are right about ColorIndex property.
But when tested your code it doesn't work as expected!!

SamT
01-11-2015, 01:24 PM
What did you expect? :)

(Select empty space below with mouse to see answer)
A1 should have value = 3.
A2 should have no value.

With any Cell, Right Click >> Format >> Patterns

Then on Excel Menu >> Tools >> Options >> Color Tab, Click third color down in second column from left (Red). Then; Click "Modify" button and see RGB Value.

When satisfied, on Color Tab, click Reset Button.

YasserKhalil
01-11-2015, 02:09 PM
I'm woking on office 2007 .. I can not get your steps Mr SamT?
Did you mean VBE or Excel itself?? I didn't find Color Tab...

SamT
01-11-2015, 06:20 PM
All in excel, except the code. I assume you have seen the code in Sheet1.

I Excel 2002 there is a Tools menu on the MenuBar. In the Tool menu is the (Excel) Options dialog where we can set many Excel Options including the actual hues, shades, and tints of each Cell color choice. Those are the 56 colors available to Format cells with.
I changed the standards colors. I set ColorIndex 3 to a green color and some other ColorIndex to RGB(255, 0, 2). Then I formatted the cells with those colors.

See this link for HowTo in 2007+ :http://support.microsoft.com/kb/288412

Here's a sub that shows all the colors of all the ColorIndexes


Sub showColorIndexNums()
Dim i As Integer, n As Integer
n = 0
Worksheets.Add before:=Sheets(1)
[A1].Value = "Color"
[B1].Value = "Index Number"
ActiveSheet.Name = "ColorIndex"
For i = 2 To 58
Range("A" & i).Interior.ColorIndex = n
Range("B" & i).Value = n
n = n + 1
Next i
ActiveSheet.[B:B].EntireColumn.AutoFit
End Sub

YasserKhalil
01-12-2015, 05:26 AM
Thanks a lot Mr SamT
I could get it now .. and thank you for this nice code

lebowski
01-13-2015, 08:21 AM
Thanks SamT, really useful to see an alternate approach again with minimal and clean code. Have much to learn.

SamT
01-13-2015, 08:54 AM
:thumb