Lookup to Return Color of a cell and not tjust the value

Toddwh1

New Member
Joined
May 19, 2010
Messages
37
I have had issue with wanting to pull in a cells color and not just the cells value. I have built this but if someone knows of an easier way to do it with a function or other <ACRONYM title="visual basic for applications">VBA</ACRONYM> please let me know. Thanks in advance.

Sub VBAlookup_Cell_Value_And_Color_Return()
' created November 2012 by Todd Hoerter
Dim lookupValue As String
Dim tableArray As String
Dim colIndexNum As String
Dim rangeLookup As String
Dim lastRow As Long
Dim rowCount As Integer
Dim currentValue As String
Dim rowNum As Long
Dim newInteriorColor As String
Dim lookupColorValue As String
Dim userInput1 As String
Dim userInput2 As String
Dim userInput3 As String
Dim userInput4 As String
Dim userInputrtWKB As Variant
Dim userInputluWKB As Variant
Dim getrtWKB As String
Dim getluWKB As String
Dim rtWBK As Workbook
Dim luWBK As Workbook

userInputrtWKB = InputBox("Workbook you are looking up From? ie. Data Return NOTE do not include the file extention")
userInputluWKB = InputBox("Workbook you are looking To? ie. Data Information NOTE do not include the file extention")
getrtWKB = (userInputrtWKB)
getluWKB = (userInputluWKB)
Set rtWBK = Workbooks(getrtWKB) ' this is the book that the valus get returned to
Set luWBK = Workbooks(getluWKB) ' this is the workbook that you lookup the values from

userInput1 = InputBox("Lookup Value? ie. A2")
userInput2 = InputBox("Table Array Pull value from what column ie.A:A?")
userInput4 = InputBox("Get Value from what column from the active lookup cell to the right, count the blank cells ie.4?")

Range("" & userInput1 & "").Select
ActiveCell(1, 2).EntireColumn.Insert
ActiveCell(0, 2).Value = "<ACRONYM title="visual basic for applications">VBA</ACRONYM> Vlookup Color Return"
Do
If ActiveCell <> "" Then
currentValue = ActiveCell.Offset(0, 0).Value

' look for the value in another worksheet or workbook
luWBK.Activate

Columns("" & userInput2 & "").Select

On Error Resume Next
Selection.Find(What:="" & currentValue & "").Select

lookupValue = ActiveCell.Offset(0, 0).Value

If currentValue = lookupValue Then
lookupValue = ActiveCell.Offset(0, "" & userInput4 & "").Value
lookupColorValue = ActiveCell.Offset(0, "" & userInput4 & "").Interior.color
newInteriorColor = lookupColorValue
If lookupColorValue = "" Then
lookupColorValue = "0"
ElseIf lookupColorValue = "16777215" Then
newInteriorColor = ""
Else:
End If
Else:
lookupValue = "#N/A"
newInteriorColor = lookupValue
End If

rtWBK.Activate

Else:
End If
' this returns the value that was found
ActiveCell.Offset(0, 1).Interior.color = (newInteriorColor)
ActiveCell.Offset(0, 1).Value = (lookupValue)
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell = ""
End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Forum statistics

Threads
1,214,643
Messages
6,120,702
Members
448,980
Latest member
CarlosWin

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
Back
Top