Duplicating a Colour in a different sheet

Hello Matt,

Welcome to the Forum!

You didn't say if your workbook has any formulas or conditional formatting in place. To provide you with a solution, It would be helpful to see the layout. Can you post the workbook? You will need to either remove or change any confidential information before you post it.

Hello Matt,

Sorry for the late reply. My ISP was down for about 9 hours today. I create 2 example workbooks based on your information. A macro is attached to the button on "Sheet1" of "Weekly Book 2". This colors the hotels based on the percentages taken from "Master Book 1". The names of the workbooks, and worksheets can be changed to what you are using. This is just an example so we can get moving in the right direction.

Sub ColorByPercentage()

  Dim Cell As Range
  Dim CI As Long
  Dim DSO As Object
  Dim DstRng As Range
  Dim DstWkb As Workbook
  Dim Key As Variant
  Dim Keys As Object
  Dim RngEnd As Range
  Dim SrcRng As Range
  Dim SrcWkb As Workbook
  
    Set DstWkb = ThisWorkbook
    Set SrcWkb = Workbooks("Master Book 1.xls")
    
    Set DstRng = DstWkb.Worksheets("Sheet1").Range("A2")
    Set RngEnd = DstRng.Parent.Cells(Rows.Count, DstRng.Column).End(xlUp)
    Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, DstRng.Parent.Range(DstRng, RngEnd))
    
    Set SrcRng = SrcWkb.Worksheets("Sheet1").Range("A2")
    Set RngEnd = SrcRng.Parent.Cells(Rows.Count, SrcRng.Column).End(xlUp)
    Set SrcRng = IIf(RngEnd.Row < SrcRng.Row, SrcRng, SrcRng.Parent.Range(SrcRng, RngEnd))
    
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
      
      For Each Cell In SrcRng
        Key = Trim(Cell.Text)
        Item = Cell.Offset(0, 1).Value
        If Key <> "" Then
          If Not DSO.Exists(Key) Then
             DSO.Add Key, Item
          End If
        End If
      Next Cell
      
      For Each Cell In DstRng
        Key = Trim(Cell.Text)
        If DSO.Exists(Key) Then
          Select Case DSO(Key) * 100
            Case 0 To 30
              CI = 3  'Red
            Case 31 To 70
              CI = 6  'Yellow
            Case 71 To 100
              CI = 5  'Green
          End Select
          Cell.Resize(1, 7).Interior.ColorIndex = CI
        End If
      Next Cell
     
    Set DSO = Nothing
    
End Sub

Hello Dianbao,

I'm assuming from this statement:

My "Master Book 1" is "HotelsLondon" and the sheets within this book are "3 Star", "4 Star" and "5 Star"

That all these sheets need to be checked for names and not just the first sheet in the "HotelsLondon" workbook.

To make the macro run automatically when the workbook is opened, copy the code below into the "weekly" workbook and follow the instructions to install it.

Private Sub Workbook_Open()

  Dim Cell As Range
  Dim CI As Long
  Dim DSO As Object
  Dim DstRng As Range
  Dim DstWkb As Workbook
  Dim Key As Variant
  Dim Keys As Object
  Dim RngEnd As Range
  Dim SrcRng As Range
  Dim SrcWkb As Workbook
  Dim SrcWks As Worksheet
  
    Set DstWkb = ThisWorkbook
    Set SrcWkb = Workbooks("HotelsLondon")
    
    Set DstRng = DstWkb.Worksheets("Sheet1").Range("A2")
    Set RngEnd = DstRng.Parent.Cells(Rows.Count, DstRng.Column).End(xlUp)
    Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, DstRng.Parent.Range(DstRng, RngEnd))
    
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
      
      For Each SrcWks In SrcWkb.Worksheets
        Set SrcRng = SrcWks.Range("A2")
        Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp)
        Set SrcRng = IIf(RngEnd.Row < SrcRng.Row, SrcRng, SrcWks.Range(SrcRng, RngEnd))
          For Each Cell In SrcRng
            Key = Trim(Cell.Text)
            Item = Cell.Offset(0, 1).Value
            If Key <> "" Then
              If Not DSO.Exists(Key) Then
                 DSO.Add Key, Item
              End If
            End If
          Next Cell
      Next SrcWks
      
      For Each Cell In DstRng
        Key = Trim(Cell.Text)
        If DSO.Exists(Key) Then
          Select Case DSO(Key) * 100
            Case 0 To 30
              CI = 3  'Red
            Case 31 To 70
              CI = 6  'Yellow
            Case 71 To 100
              CI = 5  'Green
          End Select
          Cell.Resize(1, 7).Interior.ColorIndex = CI
        End If
      Next Cell
     
    Set DSO = Nothing

End Sub

How to Save a Workbook Event Macro
1. Copy the macro using CTRL+C keys.
2. Open your Workbook and Right Click on any Worksheet's Name Tab
3. Left Click on View Code in the pop up menu.
4. Press ALT+F11 keys to open the Visual Basic Editor.
5. Press CTRL+R keys to shift the focus to the Project Explorer Window
6. Press the Down Arrow Key until ThisWorkbook is highlighted in blue.
7. Press the Enter key to move the cursor to the Code Window
8. Paste the macro code using CTRL+V
9. Save the macro in your Workbook using CTRL+S