Format transfer to sheet 2 after match in sheet1

[merken]

Dear,

I'm trying to create a warehouse heatmap within the following sheet structure.

• Data Sheet "DATA_Simplified_Loc"
  
  • Holds the location names in column A
  • Holds a sum of total picks in column H
  • Column H has 3-color scale conditional formatting
  
  
• Visualisaton Sheet "GROUND"
  
  • Holds a warehouse layout with the same location names as in sheet "DATA_Simplified_Loc" column A

Goal:

• When running script
  
  • If location name matches --> take conditional formatting from sheet "DATA_Simplified_Loc" column H (same row as match) and transfer to location name cell in sheet "GROUND"

I've attached the Excel as I am failing to succeed with the code.

Thank you.

[paulked]

If I've understood correctly then in Sheet2 code module:

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sLoc As String, c As Long
    sLoc = Cells(Target.Row, 1)
    c = Cells(Target.Row, 8).DisplayFormat.Interior.Color
    ColourCells sLoc, c
End Sub

In a code module:

Option Explicit


Sub ColourCells(sLoc As String, c As Long)
    Dim rFound As Range
    Set rFound = Sheet1.Cells.Find(what:=sLoc, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If rFound Is Nothing Then MsgBox "Not found!": Exit Sub
    Sheet1.Range(rFound.Address).Interior.Color = c
End Sub

I noticed a few typo's on the Ground sheet so I put in the "Not found!" message to pick those up. (eg S01AA10 in AR120)

[merken]

Thanks paulked.

I might sound stupid but i am not able to run the sub.
Am I doing something wrong?

[paulked]

Make a change on the Data sheet and it will update the colour on the Ground sheet. If you want to update them all in one go then run this (in Module1):

Sub ColourAll()
    Dim i As Long, rfound As Range
    On Error Resume Next
    For i = 3 To Sheet2.Cells(Rows.Count, 1).End(3).Row
        Set rfound = Sheet1.Cells.Find(what:=Sheet2.Cells(i, 1), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
        Sheet1.Range(rfound.Address).Interior.Color = Sheet2.Cells(i, 8).DisplayFormat.Interior.Color
    Next
End Sub

You could add the line

    Application.ScreenUpdating = False

After the 'Dim' line, but it won't speed it up much!

[merken]

Thanks Paulked. Works like a charm!
Thank you so much for your help.

[paulked]

You're welcome