Using Macro/VLOOKUP to return format of cell

[HazardHouse]

Hello,

I have a situation where I would like to use a vlookup formula to return the format of a cell - specifically the fill color. From what I have found by doing a bit of research, this is not possible with a formula but seems to be possible with a macro. However, while I am generally pretty good with formulas, I have no experience with VBA.

The source data and colors are in Sheet 2. I want to be able to type a value in Sheet 1 and have adjacent cells return the cell color found next to the same value on Sheet 2. The colors cannot be determined based on a formula, so I cannot use conditional formatting. I need to be able to add values with new color codes as time goes on, and there could be hundreds of values/colors in the future. Many of these colors will be custom colors using Hex color codes (not sure if that matters).

See image. I made a very basic version of what I'm trying to do. I need Column B in Sheet 1 to paste the color from Column B in Sheet 2 based on the values in column A. There will be much more data than this, but I'm trying to confirm that I can achieve what I'm looking for before I spend the time creating the entire spreadsheet. In a perfect world, as I continue to add rows in Sheet 1 and type the ID # in column A, the Color field in Column B would automatically populate like a vlookup formula.

Thank you for any help and suggestions!

 

[mumps]

This macro should take care of all the existing ID's in Sheet1:

Sub FormatCell()
    Application.ScreenUpdating = False
    Dim ID As Range
    With Sheets("Sheet1")
        For Each ID In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Set fnd = Sheets("Sheet2").Range("A:A").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                ID.Offset(, 1).Interior.Color = fnd.Offset(, 1).Interior.Color
            End If
        Next ID
    End With
    Application.ScreenUpdating = True
End Sub

To take care of the values added in column A, do the following: right click the tab name for Sheet1 and click 'View Code'. Paste the macro below into the empty code window that opens up. Close the code window to return to your sheet. Enter an ID in column A of Sheet1 and press the ENTER key.

Pr
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    Dim fnd As Range
    Application.ScreenUpdating = False
    Set fnd = Sheets("Sheet2").Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        Target.Offset(, 1).Interior.Color = fnd.Offset(, 1).Interior.Color
    End If
    Application.ScreenUpdating = True
End Sub

 

[HazardHouse]

Thank you for your help! The first part worked. I ran that macro and the colors filled in properly on Sheet 1.

The second part caused an error. After pasting that into the code window and closing the window, I typed in another ID in column A of Sheet1 and pressed enter. The code window popped back up with the error message: Compile error: Invalid outside procedure.

Just to be clear, my hope is to be able to add new IDs to Sheet2 as needed, and then also add them to Sheet1 and the color would populate in column B on Sheet1 as soon as I hit enter.

 

[mumps]

The macros I suggested worked properly on some dummy data that I entered into two sheets. It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshots (not pictures) of your two sheets. Alternately, you could upload a copy of your file (de-sensitized if necessary) to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here.

 

[HazardHouse]

I apologize for the inconvenience! Here's a link to my file Inventory Colors 041724.xlsm

 

[mumps]

The sheet names in the macros had to be changed to match your actual sheet names. Try the following macros, the first in a regular module and the second in the worksheet code module

Sub FormatCell()
    Application.ScreenUpdating = False
    Dim ID As Range
    With Sheets("Inventory")
        For Each ID In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Set fnd = Sheets("Color Database").Range("A:A").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                ID.Offset(, 1).Interior.Color = fnd.Offset(, 1).Interior.Color
            End If
        Next ID
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    Dim fnd As Range
    Application.ScreenUpdating = False
    Set fnd = Sheets("Color Database").Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        Target.Offset(, 1).Interior.Color = fnd.Offset(, 1).Interior.Color
    End If
    Application.ScreenUpdating = True
End Sub

 

[HazardHouse]

I believe this is working like a charm! The only thing I see is that if I add something to the Inventory sheet and then delete it, it replaces the color with a white fill. Is it possible to revert back to no fill when that happens?

If not, no big deal, I can just delete rows instead of just deleting the value in column A. I just figured I would ask. If that's not possible, I will mark your previous reply as the solution!

 

[mumps]

This version of the macro will simply delete the entire row if you delete a value in column A of the Inventory sheet.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    Dim fnd As Range
    Application.ScreenUpdating = False
    If Target <> "" Then
        Set fnd = Sheets("Color Database").Range("A:A").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            Target.Offset(, 1).Interior.Color = fnd.Offset(, 1).Interior.Color
        End If
    Else
        Rows(Target.Row).Delete
    End If
    Application.ScreenUpdating = True
End Sub

 

[HazardHouse]

I'm super happy with this result. Thank you so much!

 

[mumps]

You are very welcome.