Check value and copy the color to a new sheet's cell

[rmachbitz]

Basically I would like to take the file I've attached and take the Case number, for example 224.4642857, and copy its corresponding color from the Box Height to the new sheet called "Slotting". I have looked online for various code and do not know how to do this. Can someone please help?

Sub ReColour()

Dim rStart As Range, lRow1 As Long, lRow2 As Long, lRows As Long, sFind As String

Set rStart = Sheet1.Range("A1")
lRows = rStart.Offset(65000, 0).End(xlUp).Row - rStart.Row

For lRow1 = 1 To lRows
    sFind = rStart.Offset(lRow1, 3).Value
    For lRow2 = 1 To lRows
        If rStart.Offset(lRow2, 0).Value = sFind Then
            rStart.Offset(lRow1, 3).Interior.ColorIndex = rStart.Offset(lRow2, 0).Interior.ColorIndex
            rStart.Offset(lRow1, 4).Interior.ColorIndex = rStart.Offset(lRow2, 1).Interior.ColorIndex
            rStart.Offset(lRow1, 5).Interior.ColorIndex = rStart.Offset(lRow2, 2).Interior.ColorIndex
            Exit For
        End If
    Next
Next
End Sub

Coolstuff.xlsm

[Norie]

So first you want to find the case and that isn't working?

[rmachbitz]

I can do a vlookup for the Case number but I don't know how to copy the color from the Box Height corresponding to the Case number into a new sheet.

[Norie]

Option Explicit

Sub ReColour()
Dim rngCase As Range
Dim rngLookUpRange As Range
Dim rw As Range
Dim cl As Range
Dim Resp As Variant
Dim LastRow As Long
Dim LastCol As Long

    With Sheets("Organize")
        Set rngCase = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With

    With Worksheets("Slotting")
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set rngLookUpRange = .Range("B2", .Cells(LastRow, LastCol))
    End With

    For Each cl In rngCase.Cells
        For Each rw In rngLookUpRange.Rows
            Resp = Application.Match(cl.Value, rw, 0)
            If Not IsError(Resp) Then
                cl.Offset(, 1).Copy
                rw.Cells(1, Resp).PasteSpecial xlPasteFormats
                Exit For
            End If
        Next rw
    Next cl

    Application.CutCopyMode = False

End Sub

[Norie]

Why do you never refer to the other sheet, Slotting, in the code?

[rmachbitz]

Thank you again