PDA

View Full Version : [SOLVED] Format transfer to sheet 2 after match in sheet1



merken
12-10-2019, 04:48 AM
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
12-10-2019, 06:28 AM
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
12-10-2019, 07:54 AM
Thanks paulked.

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

paulked
12-10-2019, 08:35 AM
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
12-10-2019, 09:00 AM
Thanks Paulked. Works like a charm!
Thank you so much for your help.

paulked
12-10-2019, 09:12 AM
You're welcome :thumb