Certain cell Colour to Copy across once activated

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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


Screenshot 2021-02-20 231634.jpg
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
345
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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
 
Solution

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
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

Active Member
Joined
Dec 29, 2019
Messages
345
Office Version
  1. 365
Platform
  1. Windows
Glad I could help. Come back anytime if you find any bugs or get any further questions :)
 

Watch MrExcel Video

Forum statistics

Threads
1,129,685
Messages
5,637,809
Members
416,983
Latest member
LessThanAverageUser

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top