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
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
345
Office Version
  1. 365
Platform
  1. Windows
Try this in the sheet's module:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, lrLeft As Long, lrRight As Long
    
    If Target.Address = Range("A2").Address Or Target.Address = Range("B2").Address Or Target.Address = Range("C2").Address _
        Or Target.Address = Range("F2").Address Or Target.Address = Range("G2").Address 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, lrLeft).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 not blank after change clear values
        Else
            lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
            Range(Cells(3, "I"), Cells(lrRight, "O")).Value = ""
        End If
        
    End If
End Sub
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
345
Office Version
  1. 365
Platform
  1. Windows
Sorry I found a mistake in the code. Try this one:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, lrLeft As Long, lrRight As Long
   
    If Target.Address = Range("A2").Address Or Target.Address = Range("B2").Address Or Target.Address = Range("C2").Address _
        Or Target.Address = Range("F2").Address Or Target.Address = Range("G2").Address 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).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
        Else
            lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
            Range(Cells(3, "I"), Cells(lrRight, "O")).Value = ""
        End If
       
    End If
End Sub
 
Last edited:

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
Sorry I found a mistake in the code. Try this one:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, lrLeft As Long, lrRight As Long
 
    If Target.Address = Range("A2").Address Or Target.Address = Range("B2").Address Or Target.Address = Range("C2").Address _
        Or Target.Address = Range("F2").Address Or Target.Address = Range("G2").Address 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).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
        Else
            lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
            Range(Cells(3, "I"), Cells(lrRight, "O")).Value = ""
        End If
     
    End If
End Sub

Sorry I found a mistake in the code. Try this one:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, lrLeft As Long, lrRight As Long
  
    If Target.Address = Range("A2").Address Or Target.Address = Range("B2").Address Or Target.Address = Range("C2").Address _
        Or Target.Address = Range("F2").Address Or Target.Address = Range("G2").Address 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).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
        Else
            lrRight = Range("I" & Rows.Count).End(xlUp).Row + 1
            Range(Cells(3, "I"), Cells(lrRight, "O")).Value = ""
        End If
      
    End If
End Sub
Thank you so much Kanadaa, that's a lot of code. Thank you for taking the time to look at the problem for me and write a code.
I have never written code before apart from one liners in a cell. I don't even know how to bring up the area to put this code in and then how then do I save the code so that it runs in the background.
Sorry for asking.
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
345
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thank you so much Kanadaa, that's a lot of code.
You're welcome. It's actually nothing because it took only a couple of minutes to write the code.
I have never written code before apart from one liners in a cell. I don't even know how to bring up the area to put this code in and then how then do I save the code so that it runs in the background.
1. If your current workbook isn’t a macro-enabled workbook, save it as an .xlsm file
2. If you don’t have the developer tab in the ribbon, turn it on (see Developer Tab in Excel)
3. Open the code tab. In the Project tab in it, you'll see a list of worksheets you have. Choose one into which you want to install the automatic fill-in function.
4. Copy and paste the code into the sheet module
5. Exit the code tab and try typing something into a search bar and see if it works
 

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
You're welcome. It's actually nothing because it took only a couple of minutes to write the code.

1. If your current workbook isn’t a macro-enabled workbook, save it as an .xlsm file
2. If you don’t have the developer tab in the ribbon, turn it on (see Developer Tab in Excel)
3. Open the code tab. In the Project tab in it, you'll see a list of worksheets you have. Choose one into which you want to install the automatic fill-in function.
4. Copy and paste the code into the sheet module
5. Exit the code tab and try typing something into a search bar and see if it works
 

Attachments

  • code 1.jpg
    code 1.jpg
    153.4 KB · Views: 5
  • data Sheet.jpg
    data Sheet.jpg
    169.2 KB · Views: 5

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I Have copied and pasted the code but guessing its me doing something wrong here being a complete novice but at the moment it doesnt seem to work.

I have now the development added so thank you for that but other than that i am lost .Not sure also how to enable macro enabled workbook. Have tried but may have messed it up.
 

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
345
Office Version
  1. 365
Platform
  1. Windows
You've pasted the code into the right place the right way.
I think your workbook still isn't a macro-enabled workbook, which is presumably why you can't get the code to work.
Check the following images:

Capture.PNG


Capture2.PNG


Capture3.PNG
 

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows
You've pasted the code into the right place the right way.
I think your workbook still isn't a macro-enabled workbook, which is presumably why you can't get the code to work.
Check the following images:

View attachment 32714

View attachment 32715

View attachment 32716
Morning Kanadaa
Thank you,

I have now enabled the macro, but with no success-Perhaps i should upload a mini sheet to see if you can try it-not sure how that works or send you the data sheet itself.
Macro Enabled pic 2.jpg
Data pic 2.jpg
Code pic 2.jpg
 

Mike1971

New Member
Joined
Feb 20, 2021
Messages
8
Office Version
  1. 365
Platform
  1. Windows

Watch MrExcel Video

Forum statistics

Threads
1,129,685
Messages
5,637,808
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