How to copy past only the cell marked in red

[Pasi12]

pasi.jpg

Hi I am trying to copy /paste only the cells with red color font into new sheet how do I do this? I don't want the cell in black.
Thanks,
Pasi

here is my code forgot to put in:

F

or i = 1 To Range("A65536").End(xlUp).Row
'        ' If Application.WorksheetFunction.CountIf(Range("D:D"), Range("A" & i)) = 1 Then
'
'                ' ColorIndex = 3 Then
         With Range("A" & i).Font
              ' With Range("A:A").ColorIndex
               ' .Bold = True
                '.ColorIndex = 3
                Range("A" & i).Select
                Selection.Copy
           Sheets.Add After:=Sheets(Sheets.Count)
          ActiveSheet.Paste
End With
    'End If
    End If
    Next I

[ashleyuk1984]

Presuming that your data is only in columns A & B.

Sub FontColor()

LastRow = Range("A9999").End(xlUp).Row


'ColourIndex "3" = Red


For x = 1 To LastRow

'Check if the cell contains the font colour RED (3)
If Range("A" & x).Font.ColorIndex = 3 Then

'If it does, then copy the data
    Range("A" & x, "B" & x).Copy

'Check to see if A1 is blank on sheet2
        If Sheets("Sheet2").Range("A1").Value = "" Then

'If it is, then paste the data there
            Sheets("Sheet2").Range("A1").PasteSpecial xlPasteAll
            Else

'If it is already taken, then paste the data into the next row below
            Sheets("Sheet2").Range("A9999").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
        End If
End If
Next x


End Sub

I hope this helps

[Pasi12]

Thank you Ashelyuk! I am getting error on the line If Sheets("Sheet2").Range("A1").Value = "" Then it wont go further? not sure why?

[ashleyuk1984]

Do you have another sheet (a tab at the bottom) called Sheet2 ??



If you don't, then this is probably why your getting that error.

[Pasi12]

NO I don't is there any way just to say copy/paste only reds into another sheet without mentioning sheet number?
Also the code only copy pastes the first row not the rest? I only get one row copied?
Thanks so much!!!

[ashleyuk1984]

It will only copy the first row, because you are getting an error. So therefore the rest of the code can't execute.

Use: Sheets(2) instead of Sheets("Sheet2"), this will paste to your second sheet, no matter what it's called..

I have modified my code:

Sub FontColor()

LastRow = Range("A9999").End(xlUp).Row


'ColourIndex "3" = Red


For x = 1 To LastRow

'Check if the cell contains the font colour RED (3)
If Range("A" & x).Font.ColorIndex = 3 Then

'If it does, then copy the data
    Range("A" & x, "B" & x).Copy

'Check to see if A1 is blank on sheet2
        If Sheets(2).Range("A1").Value = "" Then

'If it is, then paste the data there
            Sheets(2).Range("A1").PasteSpecial xlPasteAll
            Else

'If it is already taken, then paste the data into the next row below
            Sheets(2).Range("A9999").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
        End If
End If
Next x


End Sub

[Pasi12]

This is how I have it now and its working fine with your added few lines but only copies the first row not all the red one?

Sub ColorDuplicates()
'Color duplicate items between columns A and D
    For i = 1 To Range("D65536").End(xlUp).Row
         If Application.WorksheetFunction.CountIf(Range("A:A"), Range("D" & i)) = 1 Then
            With Range("D" & i).Font
            .ColorIndex = 5
                .Bold = True
            With Range("E" & i).Font
                .ColorIndex = 5
                .Bold = True
            End With
            End With
         End If
    Next i
   For i = 1 To Range("A65536").End(xlUp).Row
         If Application.WorksheetFunction.CountIf(Range("D:D"), Range("A" & i)) = 1 Then
            With Range("A" & i).Font
            .ColorIndex = 3
                .Bold = True
                            
            With Range("B" & i).Font
                .ColorIndex = 3
                .Bold = True
             End With
            End With
            
             If Range("A" & i).Font.ColorIndex = 3 Then
                       
            Range("A" & i, "B" & i).Copy
           
             Sheets.Add After:=Sheets(Sheets.Count)
             ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).PasteSpecial xlPasteAll
    ActiveSheet.Paste
   
   End If
                     
            End If
              
       
   
   
    Next i

[Pasi12]

Sorry still getting If Sheets(2).Range("A1").Value = "" Then error? with you new code?

[jolivanes]

Or you could try this.

Sub Try_This()
    Dim c As Range
    For Each c In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        If c.Font.ColorIndex = 3 Then c.Resize(, 2).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
    Next c
End Sub

If you have a large range, autofilter will be faster

[Pasi12]

Getting error on this section: c.Resize(, 2).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)

[ashleyuk1984]

Not really sure why your getting errors on that line.
Unless there is something specific on your workbook preventing it.

Are you able to upload a copy of your workbook so we can analyse it.

[jolivanes]

What does the error say?
Do you have a Sheet called "Sheet2"? Previously you mentioned that you didn't
Change the Sheets("Sheet2") to Sheets("Sheetname where you want it copied into")

[Pasi12]

How do I upload this file? Can you set it just to copy all the reds cells from current sheet to another sheet without mentioning the sheet(2)? like what I had: " Sheets.Add After:=Sheets(Sheets.Count)" ?
Thanks!

[Pasi12]

Its says script out of range and highlite in yellow " c.Resize(, 2).Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1)" ? Can you just say next sheet .add? like ---> Sheets.Add After:=Sheets(Sheets.Count)'
Thanks!

[ashleyuk1984]

Theres an attachment button when you choose to reply via the advanced form.

[Pasi12]

AhleyUk file is attached.
tanks.

[ashleyuk1984]

Hi,
I'm not really sure why your getting the errors ??

I just ran my code on your uploaded workbook, and this is the results that I got.



I believe this is what you want - more or less.
As for the errors that you seem to be getting?? I don't know? My code seems to work perfectly fine on my end.

[Pasi12]

HI ,

That is strange! not sure whats going on?? hmmm???

Thank you!!!!

[Pasi12]

Ok I think I know what it is! When I open my xls sheet it only has 1 sheet with data in it your codes is looking for sheet 2 which is not there. I think that's why! Any way to modify the code not to look for sheet number ? just say : Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste

That would be great!
Thanks so much!

[jolivanes]

Try the attached