PDA

View Full Version : How to copy past only the cell marked in red



Pasi12
01-23-2014, 10:39 AM
11150

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, :crying:
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
01-23-2014, 02:54 PM
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
01-23-2014, 03:06 PM
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
01-23-2014, 03:25 PM
Do you have another sheet (a tab at the bottom) called Sheet2 ??

http://www.ultraimg.com/images/BwjOT.png

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

Pasi12
01-23-2014, 03:39 PM
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
01-23-2014, 03:46 PM
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
01-23-2014, 03:47 PM
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
01-23-2014, 03:51 PM
Sorry still getting If Sheets(2).Range("A1").Value = "" Then error? with you new code?

jolivanes
01-23-2014, 03:52 PM
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
01-23-2014, 03:56 PM
Getting error on this section: c.Resize(, 2).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)

ashleyuk1984
01-23-2014, 04:04 PM
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
01-23-2014, 04:07 PM
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
01-23-2014, 04:10 PM
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
01-23-2014, 04:14 PM
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
01-23-2014, 04:14 PM
Theres an attachment button when you choose to reply via the advanced form.

http://www.ultraimg.com/images/FdTUc.png

http://www.ultraimg.com/images/CWEID.png

Pasi12
01-23-2014, 04:21 PM
AhleyUk file is attached.
tanks.

ashleyuk1984
01-23-2014, 04:27 PM
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.

http://www.ultraimg.com/images/CYVrm.png

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
01-23-2014, 04:31 PM
HI ,

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

Thank you!!!!

Pasi12
01-23-2014, 04:41 PM
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
01-23-2014, 04:45 PM
Try the attached

ashleyuk1984
01-23-2014, 04:49 PM
Ahhh, I see. OK this should do the trick.


Sub FontColor()'ColourIndex "3" = Red


'Add new sheet and then select original sheet to continue work
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(1).Select

'Find LastRow on original sheet.
LastRow = Range("A9999").End(xlUp).Row

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
01-23-2014, 04:58 PM
Awsome!!!! thanks so much!!!!!

jolivanes
01-23-2014, 05:00 PM
I guess you've got it going. Good.
Anyway, I had this ready so here it is.


Sub Try_This()
Dim c As Range
If ActiveWorkbook.Sheets.Count = 1 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Sheet2"
Sheets("Sheet1").Select
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(2).Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next c
End Sub
Good luck

Pasi12
01-23-2014, 05:03 PM
Thank you! It works! you are awesome!!! The only thing is that when I combined your code with mine ( mine looks for macth and colors them red and blue) it runs slow not sure why? You Rock!!!!
thanks again!!!!

Pasi12
01-23-2014, 05:11 PM
Thank you Jolivanes!! You Rock as well!!! thanks a bunch!!!:):hi::friends:

Pasi12
01-23-2014, 07:51 PM
Hi again,

Is there any way to find match within a workbook/sheet instead of only 2 columns? like in my case I like to be able to search within workbook for those match's?
Thanks!

Pasi12
01-24-2014, 09:00 AM
Hello Ashley,

Sorry to bother, had another question, si there a way to tell how many rows in worksheet has data in it and count them and report it to screen? like in my case, once I copied all the cells in red, I want to count them with a popup to screen? with the msg poup like below:

CreateObject("Wscript.Shell").Popup " Number of Worksheets " & Worksheets.count, 1, "Worksheets", vbSystemModal


Thanks!
Pasi



Ahhh, I see. OK this should do the trick.


Sub FontColor()'ColourIndex "3" = Red


'Add new sheet and then select original sheet to continue work
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(1).Select

'Find LastRow on original sheet.
LastRow = Range("A9999").End(xlUp).Row

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

jolivanes
01-24-2014, 09:41 AM
Like this?


MsgBox WorksheetFunction.Counta("A:A")


From VB Help:
Use CountA to count the number of cells that contain data in a range or array.
A value is any type of information, including error values and empty text (""). A value does not include empty cells.
If an argument is an array or reference, only values in that array or reference are used. Empty cells and text values in the array or reference are ignored.
If you do not need to count logical values, text, or error values, use the Count function.

ashleyuk1984
01-24-2014, 10:00 AM
Stick this at the end of your macro.


MsgBox Sheets(2).Range("A9999").End(xlUp).Row

http://ultraimg.com/images/EPOsg.png

Pasi12
01-24-2014, 12:27 PM
Thanks you Ashley! You've been great. I had another question which I posted earlier but I ask again, is there a way to dynamically search a worksheet for duplicates instead of giving it a columns?
Like in my case I want to be able to just search the worksheet for any matches within columns and report it?

Thanks!



Stick this at the end of your macro.


MsgBox Sheets(2).Range("A9999").End(xlUp).Row

http://ultraimg.com/images/EPOsg.png

ashleyuk1984
01-24-2014, 01:05 PM
No problem happy to help.
So are you just doing the equivalent of 'Find' ?? Or something else?
Could you give an example of what you'd like on your workbook?

Or do you mean, you want to capture every cell with red text? Not just columns A & B ?

Pasi12
01-24-2014, 01:10 PM
Yes - Thank! first- can you tell me how do I copy the headers with your code into new sheet? right now it only copies the red cell only not header?
2nd- so right now my code looks into column A and D and if it finds match it will color them red and blue and then I use your code you to copy those red cells to new sheet. Now I want to see if there is any way just to do this globally without giving it a column? like search the entire sheets for cell match ?

You are a sweet heart!

jolivanes
01-26-2014, 01:43 PM
Here is another way of copying the desired colors.
Just select a colored cell in any column and click on the button.

snb
01-26-2014, 03:05 PM
Why not using Excel's (2010) builtin facilities ?


Sub M_snb()
With Sheet1.Cells(1).CurrentRegion
.AutoFilter 1, RGB(255, 0, 0), 9
.Offset(1).Copy Sheets("sheet2").Cells(1)
.AutoFilter
End With
End Sub

jolivanes
01-26-2014, 04:11 PM
@ snb
Probaly because
1) I don't have 2010
2) I was not aware that it even exist
3) Does not help me trying to write code!!!!
4) Color is hard coded
5) You have to know the RGB codes
6) Column is not a choice

However, you can change it to this and it does work in 2007.

Sub M_snb()
With Sheet1.Cells(1).CurrentRegion
'.AutoFilter 1, rgb(255, 0, 0), 9
.AutoFilter 1, ActiveCell.Font.Color, 9
.Offset(1).Copy Sheets("sheet2").Cells(1)
.AutoFilter
End With
End Sub

But anyway, thanks for the shorter code.

Pasi12
01-26-2014, 06:41 PM
thank you Jolivanes, I will try it and let you know! much appreciate!
Pasi.

Pasi12
01-26-2014, 06:47 PM
SNB,

I am not sure what this code suppose to do? I ran it but didn't do anything?
THnx

snb
01-27-2014, 02:40 AM
@ snb
Probaly because
1) I don't have 2010
2) I was not aware that it even exist
3) Does not help me trying to write code!!!!
4) Color is hard coded
5) You have to know the RGB codes
6) Column is not a choice

However, you can change it to this and it does work in 2007.

@jolivanes


1 I didn't state it only works in 2010; I only indicated that the code runs in 2010
2 that's why I posted this suggestion
3 it does; offering alternatives is always a stimulus to look further; that will improve your code writing skills
4 you are stating the obvious; that is correct. You are allowed to adapt any of my suggestions anytime (and I hope you will). I never offer solutions, only suggestions to attain your goal if you have at least the intention to do the coding yourself.
5 that's obvious too.
6 very well observed; but did I suggest otherwise ?

Yes it also works in 2007 (and 2013).

@Pasi12

Do not run code you do not understand. Analyse it before running it.

jolivanes
01-27-2014, 09:12 AM
@snb
Fair enough from my standpoint. It mostly boils down your answers #'s 3 and 4 I guess.
Thank you sir ( I assume) for that.

@Pasi12
snb's code adapted for you. More needs to be added but as snb suggested, understand it and then work at it yourself.

Sub M_snb()
Application.ScreenUpdating = False
Dim response
response = MsgBox("Did you select the rightcell?", vbYesNo, "Right Choice?")
If response = vbNo Then
Exit Sub
Else
With Sheet1.Cells(1).CurrentRegion
.AutoFilter Selection.Column, ActiveCell.Font.Color, 9
.Offset(1).Copy Sheets("sheet2").Cells(1)
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub

Pasi12
01-27-2014, 09:28 AM
thank you both for you great support! Thank god we have these Forums!

snb
01-27-2014, 01:42 PM
In that case, to avoid gender mistakes: 'no objection your honour' :whistle:

I'd prefer:


Sub M_snb()
Application.ScreenUpdating = False

if MsgBox("Did you select the rightcell?", vbYesNo, "Right Choice?") =vbYes Then
With Sheet1.Cells(1).CurrentRegion
.AutoFilter ActiveCell.Column, ActiveCell.Font.Color, 9
.Offset(1).Copy Sheets("sheet2").Cells(1)
.AutoFilter
End With
end if

Application.ScreenUpdating = True
End Sub

Pasi12
01-27-2014, 02:27 PM
Yes your master! Thanks!:)

jolivanes
01-27-2014, 02:54 PM
Re: In that case, to avoid gender mistakes: 'no objection your honour'

Right on. Good to see people still have time for fun.
Mind you, you have an advantage as this is a public forum and I am not allowed to say what I could say after that remark.
Have a good and fun day.
And thanks for all the lessons over time of course.

snb
01-27-2014, 02:58 PM
That's the main reason we are here don't you think ? :rotlaugh:

Pasi12
01-27-2014, 03:05 PM
Absebootly! :) I have another question and need help hope you gents can help with other post with duplicates?

jolivanes
01-27-2014, 04:12 PM
I subscribe to that, even not being a "Tukker"