Certain cell Colour to Copy across once activated

[Mike1971]

Hi All,

Hope you can help.

I have created a search bar that highlights the entire row when typing in either name of street, map no, map name, postcode etc-When i type in the Name of a street it highlights it with a specific colour
and the same for thing map no etc and then that shows up as blue etc. These lines disappear when the search bar cell has been deleted of search words.

This list is very long and i wish to create a results table next to the list so i dont have to go through all the lines and scroll through them.

I would like to know how to create a formula or how to use a macro to say for example if in column A3- A500 say appears to come up as gold colour then copy it to i3,etc-so i have a neat list at the top.

Not very good at explaining , but hopefully the pic will help,

Please advise
Regards
Mike

 

[kanadaaa]

Hi Mike. As we talked in the PM I'm posting a revised version of the code here.
Replace everything in the sheet module with the code below and give it another try.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, lrLeft As Long, lrRight As Long
  
    If InStr(Target.Address, Range("A2").Address) > 0 Or InStr(Target.Address, Range("B2").Address) > 0 Or _
        InStr(Target.Address, Range("C2").Address) > 0 Or InStr(Target.Address, Range("F2").Address) > 0 Or _
        InStr(Target.Address, Range("G2").Address) > 0 Then 'If A2, B2, C2, F2, or G2 is changed
      
        'If not blank after change, output values
        If Range("A2") <> "" Or Range("B2") <> "" Or Range("C2") <> "" Or Range("F2") <> "" Or Range("G2") <> "" Then
            lrLeft = Range("A" & Rows.Count).End(xlUp).Row
            Application.ScreenUpdating = False
            For i = 3 To lrLeft
                If Cells(i, 1).DisplayFormat.Interior.ColorIndex <> -4142 Then
                    lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
                    Cells(lrRight, "I").Resize(, Columns("G").Column).Value = Cells(i, "A").Resize(, Columns("G").Column).Value
                End If
            Next i
            Application.ScreenUpdating = True
          
        'If blank after change, clear values (and re-output)
        Else
            lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
            Range(Cells(3, "I"), Cells(lrRight, "O")).Value = ""
            lrLeft = Range("A" & Rows.Count).End(xlUp).Row
            Application.ScreenUpdating = False
            For i = 3 To lrLeft
                If Cells(i, 1).DisplayFormat.Interior.ColorIndex <> -4142 Then
                    lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
                    Cells(lrRight, "I").Resize(, Columns("G").Column).Value = Cells(i, "A").Resize(, Columns("G").Column).Value
                End If
            Next i
            Application.ScreenUpdating = True
        End If
      
    End If
End Sub

 

[Mike1971]

Hi Mike. As we talked in the PM I'm posting a revised version of the code here.
Replace everything in the sheet module with the code below and give it another try.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, lrLeft As Long, lrRight As Long

    If InStr(Target.Address, Range("A2").Address) > 0 Or InStr(Target.Address, Range("B2").Address) > 0 Or _
        InStr(Target.Address, Range("C2").Address) > 0 Or InStr(Target.Address, Range("F2").Address) > 0 Or _
        InStr(Target.Address, Range("G2").Address) > 0 Then 'If A2, B2, C2, F2, or G2 is changed
    
        'If not blank after change, output values
        If Range("A2") <> "" Or Range("B2") <> "" Or Range("C2") <> "" Or Range("F2") <> "" Or Range("G2") <> "" Then
            lrLeft = Range("A" & Rows.Count).End(xlUp).Row
            Application.ScreenUpdating = False
            For i = 3 To lrLeft
                If Cells(i, 1).DisplayFormat.Interior.ColorIndex <> -4142 Then
                    lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
                    Cells(lrRight, "I").Resize(, Columns("G").Column).Value = Cells(i, "A").Resize(, Columns("G").Column).Value
                End If
            Next i
            Application.ScreenUpdating = True
        
        'If blank after change, clear values (and re-output)
        Else
            lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
            Range(Cells(3, "I"), Cells(lrRight, "O")).Value = ""
            lrLeft = Range("A" & Rows.Count).End(xlUp).Row
            Application.ScreenUpdating = False
            For i = 3 To lrLeft
                If Cells(i, 1).DisplayFormat.Interior.ColorIndex <> -4142 Then
                    lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
                    Cells(lrRight, "I").Resize(, Columns("G").Column).Value = Cells(i, "A").Resize(, Columns("G").Column).Value
                End If
            Next i
            Application.ScreenUpdating = True
        End If
    
    End If
End Sub
[/CO
[/QUOTE]

 

[Mike1971]

Oh My Days, You are Amazing-That worked even better than expected,

Thank you so much Kanadaaa-

You have saved me many sleepless weeks- i cant thank you enough.

 

[kanadaaa]

Glad I could help. Come back anytime if you find any bugs or get any further questions