macro - copy all rows with colorindex 36

[flymo]

Hello All,
Totally new to excel macros and wondered if I could get some guidance.

I have a series of worksheets - one main and several that will be
populated from that sheet.

When certain records meet criteria, I use light yellow as a
highlighter for the background.....I need to be able to collect all
the highlighted records from sheet - 1st Assn to sheet - Failures.

I have the following macro recorded but it takes all the records not
the yellow ones (I set the format in Edit ->Find->Options etc set the
color etc.


Application.FindFormat.Clear
With Application.FindFormat.Interior
.ColorIndex = 36
End With
Range("C13248").Select
Selection.Copy
Sheets("Failures").Select
Range("C13248").Select
ActiveSheet.Paste


I have searched the groups for similar solutions and tried without
success.

Any help would be appreciated.

John

 

[Guest]

Looking in the Object Browser, I find that the Interior property is a member
of FormatConditions and CellFormat, but not FindFormat. You also need to
know how the color was assigned to the cell, whether

Range(myRangeVar).Interior.ColorIndex = SomeNumber

Or

Range(myRangeVar).FormatConditions.Interior.ColorIndex = SomeNumber

These are two different levels of applying the color to a cell, but they
look the same to the casual observer.

 

[Guest]

I'll give you a snippet of code and you can modify to suit.

Sub CopyYellow()
Dim myRange As Range
Dim myCopyRange As Range
Dim r As Range
Dim sht As Worksheet

Set sht = Worksheets("Failures")
Set myRange = Range("C13248")
For Each r In myRange
If r.Interior.ColorIndex = 36 Then
If Not IsEmpty(r) Then
Debug.Print r.Address,
Debug.Print r.Text,
Debug.Print r.Value
sht.Range(r.Address).Value = r.Value
Debug.Print r.Address
End If
End If
Next r

End Sub

HTH,
Barb Reinhardt

 

[tissot.emmanuel]

Hi,

You may use AutoFilter to hide records that doesn't match your criterias
then SpecialCells to copy.

Sub FilterThenCopy()
Dim MyData As Range
Set MyData = Range("A1:F1000") 'Your data
With MyData
.AutoFilter Field:=1, Criteria1:=">0"'Use criteria >0 on field 1
.SpecialCells(xlCellTypeVisible).Copy 'Copy all records where field1

0

End With
Sheets("Failures").Activate
ActiveSheet.Paste
MyData.AutoFilter 'Remove Autofilter
End Sub

Regards,

Manu/

 

[flymo]

Hello,
Thanks for the response.

I've tried to adjust the code without success ( the FormatConditions
cuases an error)

The format is being applied to a range of cells by a userfrom the Fill
Color menu (selecting light yellow) - is this the choice in using the
first or second option?

I may be missing your point - apologies

John

 

[flymo]

Hello Barb,
Many thanks that is so close to what I need.

Sub CopyYellow()
Dim myRange As Range
Dim myCopyRange As Range
Dim r As Range
Dim sht As Worksheet

Set sht = Worksheets("Failures")
Set myRange = Range("C13248")
For Each r In myRange
If r.Interior.ColorIndex = 36 Then
If Not IsEmpty(r) Then
Debug.Print r.Address,
Debug.Print r.Text,
Debug.Print r.Value
sht.Range(r.Address).Value = r.Value
Debug.Print r.Address
End If
End If
Next r

End Sub


I've ran a few times and would ask two questions - what would I need
to add to the code to remove any spaces (non-yellow rows) on the
target worksheet and how do I carry over the color?
Thanks Again

Best regards
John

 

[Ron de Bruin]

Hi flymo

Check out EasyFilter
http://www.rondebruin.nl/easyfilter.htm

 

[flymo]

Thanks Ron,

I'll check it out.

Appreciated

John

 

[flymo]

Hello Folks,
I have been trying to manipulate the following (excellent) code from
Barb without success.
The code does move the rows hightlighting with colorindex 36 to the
new worksheet, however, I need to remove the spaces (there may be
hundreds of records with only some highlighted) between records on the
new worksheet.
Having the color copy too would be great.

Sub CopyYellow()
Dim myRange As Range
Dim myCopyRange As Range
Dim r As Range
Dim sht As Worksheet

Set sht = Worksheets("Failures")
Set myRange = Range("C13248")
For Each r In myRange
If r.Interior.ColorIndex = 36 Then
If Not IsEmpty(r) Then
Debug.Print r.Address,
Debug.Print r.Text,
Debug.Print r.Value
sht.Range(r.Address).Value = r.Value
Debug.Print r.Address
End If
End If
Next r

End Sub

I would really appreciate any help as I'm at a loss(and new to excel
vba/macros) I need to get a good reference manual for this!

many thanks
John


Ron, I tried the EasyFilter and may not have using correctly -
couldn't get it to do what I needed (excellent tool tho')

 

[Ron de Bruin]

You can filter on a color in a column and choose the option to copy to a new sheet.
did you try that ?

 

[flymo]

Hello Ron,
Yes, I tried that option and couldn't get it to work properly - I need
to add to a sheet within the current workbook. So while it did filter
and place the data in a new sheet, I didn't know how to get it to
apply to the one I needed.

Best regards
John

 

[Ron de Bruin]

Sorry the add-in have only a option to copy in the same sheet (below or next to your data), new sheet or new workbook

 

[Brian Bennett]

John, try this one. (it's not mine, but one I found)

Sub DeleteRowsThatLookEmptyinColE()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim Rng As Range, ix As Long
Set Rng = Intersect(Range("E:E"), Sheet1.UsedRange)
For ix = Rng.Count To 1 Step -1
If Trim(Replace(Rng.Item(ix).Text, Chr(160), Chr(32))) = "" Then
Rng.Item(ix).EntireRow.Delete
End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[flymo]

Hi Brian,
Thanks for the info - I'll try that.

Regards
John