help with vba adaption

[blueroost]

Came across this code but trying to adapt it slightly

The code searches column e for the word bottle, copies and pastes the whole row where the word bottle appears in sheet 2.

What i want to change is ;

search a range ie - a4:f20 (as opposed to only column e)

Search criteria will be by font colour (blue for example ) Font.ColorIndex = 5 and only if there is no other fill colour in the cell.

Have tried to adapt but i keep getting errors , Original Code;

Sub SearchForString()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 4
LSearchRow = 4

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub


Many Thanks

 

[blueroost]

Slight change to original e mail, (criteria is mail box not bottles)

Came across this code but trying to adapt it slightly

The code searches column e for the word "Mail Box", copies and pastes the whole row where the word bottle appears in sheet 2.

What i want to change is ;

search a range ie - a4:f20 (as opposed to only column e)

Search criteria will be by font colour (blue for example ) Font.ColorIndex = 5 and only if there is no other fill colour in the cell.

Have tried to adapt but i keep getting errors , Original Code;

Sub SearchForString()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 4
LSearchRow = 4

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub


Many Thanks

 

[Norie]

Can you post the adapted code and tell us how it isn't working?

 

[blueroost]

ok, not too clued up on vba so will highlight in red what i changed in a hope that it would search range a4:f20 for anything with font colour blue, then paste in new sheet


Sub SearchForString()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 4
LSearchRow = 4

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("A4:F20" & CStr(LSearchRow)).Value = Font.ColorIndex = 5 Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub


Many Thanks

 

[Norie]

I'm afraid that will definitely not search the range, for the colour index or anything else.

You can't really search an entire range in one fell swoop like that.

The original code is searching column E row by row (or cell by cell I suppose) then copying and pasting if the criteria is found.

What exactly is your criteria?

The range you mention has 6 columns and multiple rows.

 

[blueroost]

mmmm, this does not look good

The range i am searching has 13 column and around 150 rows

basically searching due dates, they will change colour when due out of date etc.

my idea was due dates that have not been dealt with "amber font and no colour fill", could be copied into new sheet.

a kind of filtering report.

 

[blueroost]

ok found another code that finds the blue font

Sub findBlueCharacter()
Dim cl As Range
Dim iCharacter As Integer
For Each cl In ActiveSheet.Range("a1:c2")
If Len(cl) > 0 Then
For iCharacter = 1 To cl.Characters.Count
If cl.Characters(iCharacter, 1).Font.ColorIndex = 5 Then
cl.Select
Exit Sub
End If
Next iCharacter
End If
Next cl
End Sub

is there any way i could mash these two together so that it

finds the font colour

copy / paste row

look for next row with font colour

copy / paste row

until it reaches the end (blank cell i guess)

 

[blueroost]

Do I have to repeat search for each column , if so how do i search the font colour

help please, not much hair left

 

[Norie]

It's still not clear exactly what the criteria is.

The code you've posted now is checking the font colour of every character of every value in the range A1:C2.

What is it you want to check for?

Do you want to check row by row, column by column, cell by cell?

 

[blueroost]

I want it to look at a range, not sure how it will do it, row by row etc

it will look for the cell that has the "font colour of choice" lets say amber

there will only be one in each row, cell in row will change as per calender but will always only be one cell with amber coloured font in each row.

the amber coloured font represents a due date.

if i do the task that is due, i will fill the cell grey, (font will still be amber, its conditional formatting)

so i want to scan through my range, find the cells that have amber font and not filled with a colour and paste that entire row in a new sheet.

i have explained it slightly different in this post with screen shot
http://www.mrexcel.com/forum/showthread.php?t=484652&highlight=copy+filter

it could be impossible but seems so simple

thank you for your replies