Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
Still stuck on a problem from a few days ago. I am trying to identify,
select, and copy all data in any row (copy the entire row) if a cells has any red text in it. Then I want to move these items to a new sheet, lets call it €śSummary Sheet€ť. Earlier in the week, I was playing with two concepts; so far I have been unable to get either one working. Id appreciate any help. Concept#1 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select If x = 1 Then Set redFonts = Union(redFonts, cell) Else Set redFonts = cell x = 1 End If End If Next c c.EntireRow.Select redFonts.Select Worksheets.Add.Name = "Summary" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Concept#2 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Dim rw As Long Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select Worksheets("Summary").Cells(rw, 1).Value = cell.Value rw = rw + 1 End If Next End Sub Thanks, Ryan-- -- RyGuy |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
We start out with a function is_it_red that returns true if any cell in a row
has red font. We loop down the rows, looking for Truth. If we find Truth, we copy the entire row and paste it in another worksheet and bump the paste counter: Function is_it_red(i As Long) As Boolean is_it_red = False For j = 1 To Columns.Count If Cells(i, j).Font.ColorIndex = 3 Then is_it_red = True Exit Function End If Next End Function Sub colorcopier() Dim i As Long k = 1 Set r = ActiveSheet.UsedRange nLastRow = r.Rows.Count + r.Row - 1 For i = 1 To nLastRow If is_it_red(i) Then Set rc = Cells(i, 1).EntireRow Set rd = Sheets("Summary").Cells(k, 1) rc.Copy rd k = k + 1 End If Next End Sub -- Gary''s Student - gsnu200753 "ryguy7272" wrote: Still stuck on a problem from a few days ago. I am trying to identify, select, and copy all data in any row (copy the entire row) if a cells has any red text in it. Then I want to move these items to a new sheet, lets call it €śSummary Sheet€ť. Earlier in the week, I was playing with two concepts; so far I have been unable to get either one working. Id appreciate any help. Concept#1 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select If x = 1 Then Set redFonts = Union(redFonts, cell) Else Set redFonts = cell x = 1 End If End If Next c c.EntireRow.Select redFonts.Select Worksheets.Add.Name = "Summary" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Concept#2 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Dim rw As Long Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select Worksheets("Summary").Cells(rw, 1).Value = cell.Value rw = rw + 1 End If Next End Sub Thanks, Ryan-- -- RyGuy |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
hi
i copied your code and try to run it. crashed left and right. i knew it would. why? concept 1.... cell has not been set. value = nothing redfonts has not been set. value = nothing x has not been assigned a value workbook.add in wrong place selection not selected. c.entirerow.select outside of loop trying to stick as close to your code as possible..... i did modify some, added some and commented out sections that didn't seem to have any purpose...... Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) Worksheets.Add.Name = "Summary" Sheets("sheet1").Activate For Each c In SearchRange If c.Font.ColorIndex = 3 Then c.EntireRow.Copy Sheets("summary").Activate Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues Sheets("sheet1").Activate 'If x = 1 Then 'Set redFonts = Union(redFonts, cell) 'Else 'Set redFonts = cell 'x = 1 'End If End If Next c 'c.EntireRow.Select 'redFonts.Select 'Worksheets.Add.Name = "Summary" 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 'SkipBlanks _ ':=False, Transpose:=False End Sub concept2 cell has not been set. value = nothing rw has not been assigned a value other problems too. i didn't rewrite this one. If you are useing variable, you have to assign then a value or set them somehow. and remember. code executes one line after another. be sure the sequences are in the correct order. copy something before you paste. create the worksheet before you paste to it. regards FSt1 "ryguy7272" wrote: Still stuck on a problem from a few days ago. I am trying to identify, select, and copy all data in any row (copy the entire row) if a cells has any red text in it. Then I want to move these items to a new sheet, lets call it €śSummary Sheet€ť. Earlier in the week, I was playing with two concepts; so far I have been unable to get either one working. Id appreciate any help. Concept#1 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select If x = 1 Then Set redFonts = Union(redFonts, cell) Else Set redFonts = cell x = 1 End If End If Next c c.EntireRow.Select redFonts.Select Worksheets.Add.Name = "Summary" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Concept#2 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Dim rw As Long Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select Worksheets("Summary").Cells(rw, 1).Value = cell.Value rw = rw + 1 End If Next End Sub Thanks, Ryan-- -- RyGuy |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
If Font.ColorIndex = 3, Copy Entire Row and Paste to New Sheet
Thanks for the insight GS, and thanks to you FSt1!
Cordially, Ryan- -- RyGuy "FSt1" wrote: hi i copied your code and try to run it. crashed left and right. i knew it would. why? concept 1.... cell has not been set. value = nothing redfonts has not been set. value = nothing x has not been assigned a value workbook.add in wrong place selection not selected. c.entirerow.select outside of loop trying to stick as close to your code as possible..... i did modify some, added some and commented out sections that didn't seem to have any purpose...... Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) Worksheets.Add.Name = "Summary" Sheets("sheet1").Activate For Each c In SearchRange If c.Font.ColorIndex = 3 Then c.EntireRow.Copy Sheets("summary").Activate Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues Sheets("sheet1").Activate 'If x = 1 Then 'Set redFonts = Union(redFonts, cell) 'Else 'Set redFonts = cell 'x = 1 'End If End If Next c 'c.EntireRow.Select 'redFonts.Select 'Worksheets.Add.Name = "Summary" 'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, 'SkipBlanks _ ':=False, Transpose:=False End Sub concept2 cell has not been set. value = nothing rw has not been assigned a value other problems too. i didn't rewrite this one. If you are useing variable, you have to assign then a value or set them somehow. and remember. code executes one line after another. be sure the sequences are in the correct order. copy something before you paste. create the worksheet before you paste to it. regards FSt1 "ryguy7272" wrote: Still stuck on a problem from a few days ago. I am trying to identify, select, and copy all data in any row (copy the entire row) if a cells has any red text in it. Then I want to move these items to a new sheet, lets call it €śSummary Sheet€ť. Earlier in the week, I was playing with two concepts; so far I have been unable to get either one working. Id appreciate any help. Concept#1 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select If x = 1 Then Set redFonts = Union(redFonts, cell) Else Set redFonts = cell x = 1 End If End If Next c c.EntireRow.Select redFonts.Select Worksheets.Add.Name = "Summary" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Concept#2 Sub Select_Red_Fonts() Dim c As Range, SearchRange As Range, cell As Range, redFonts As Range, x Dim rw As Long Set SearchRange = Cells.SpecialCells(xlCellTypeConstants) For Each c In SearchRange If cell.Font.ColorIndex = 3 Then c.EntireRow.Select Worksheets("Summary").Cells(rw, 1).Value = cell.Value rw = rw + 1 End If Next End Sub Thanks, Ryan-- -- RyGuy |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
How can I copy and paste an entire workbook? | Excel Worksheet Functions | |||
how do i copy an entire workbook and paste it in another | New Users to Excel | |||
Macro - copy entire row and paste at bottom of another sheet | Excel Programming | |||
vba: setting font color to entire sheet | Excel Programming | |||
How copy format, font, color and border without copy/paste? | Excel Programming |