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
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!!
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...
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.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.