Converting pantone to rgb macro

[AnnaB100]

Is there any way to colour a cell on excel based on a corresponding pantone colour?

I work for a clothing company & we need a way to automate 'boards' that show flow of colour through a season by style.

Ulimately need to build a macro that will fill cells with rgb colour based on:
- unique product's corresponding pantone ref, e.g. 13-0535TPG, to determine the colour of the cell
- unique product's estimated arrival week of & X selling weeks after, to determine which cells are to be coloured (each calendar week would be an individual column)

Any help much appreciated, very stuck at the mo!

 

[6StringJazzer]

The Pantone numbers are their proprietary ID numbers. They do not contain intelligence to determine what color it is, so there is no algorithm to do a conversion. You have to have a list of their numbers and corresponding RBG numbers. Pantone may make this available but I think you would need some sort of paid subscription. There are conversion tools I have found on the web but they do not use the same Pantone reference number format as the one you show here (and also they are paid subscriptions).

One option that would be effective but brittle is that Pantone allows you to bring up a color on a web page (here is your example) and VBA could scrape the web page to get the RGB number used. I would suggest this would be done by pressing a button to run the macro and filling in any codes needed. To do this would require a detailed description of what your Excel file looks like.

BENEFIT: It's free and it's not super hard
DRAWBACK: If Pantone decides to change the way the web page is coded, or the URLs, the code would stop working.

 

[6StringJazzer]

Here is a working prototype. This requires references to be set to VBScript and XML. This code would go into the worksheet module for the worksheet containing your data. It reads the Pantone code from cell A2 and returns the RGB numbers in B2:D2. If an error occurs it is displayed in E2. The cell containing the color code is filled with that color.

Public Sub Test()

   Dim R As Long, G As Long, B As Long
   Dim ErrMsg As String
  
   PantoneConvert Range("A2"), R, G, B, ErrMsg
  
   Range("B2:E2") = Array(R, G, B, ErrMsg)
   Range("A2").Interior.Color = RGB(R, G, B)

End Sub

' The parameters default to ByRef but are explicit here because they *must* be ByRef for this to work
Public Sub PantoneConvert(PantoneColorCode As String, ByRef R As Long, ByRef G As Long, ByRef B As Long, ByRef ErrMsg As String)

   Dim xmlhttp As New MSXML2.XMLHTTP60
   Dim PantoneURL As String
   Const DefnPattern = """rgb"":{""Red"":(\d+),""Green"":(\d+),""Blue"":(\d+)}"
   Dim Result As String
   Dim Defn As String
   Dim Results As Variant
   '"rgb":{"Red":201,"Green":232,"Blue":129}
  
  
  
   PantoneURL = "https://www.pantone.com/connect/" & Replace(PantoneColorCode, " ", "-")
  
   xmlhttp.Open "GET", PantoneURL, False
  
   xmlhttp.Send
  
   Results = RegExpFind(xmlhttp.ResponseText, DefnPattern)
 
   If IsEmpty(Results) Then
      ErrMsg = "Could not retrieve color from web page " & vbCrLf & xmlhttp.ResponseText
   Else
      
         R = RegExpSubstitute(ReplaceIn:=Results(0), _
                                   ReplaceWhat:=DefnPattern, _
                                   ReplaceWith:="$1")
         G = RegExpSubstitute(ReplaceIn:=Results(0), _
                                   ReplaceWhat:=DefnPattern, _
                                   ReplaceWith:="$2")
         B = RegExpSubstitute(ReplaceIn:=Results(0), _
                                   ReplaceWhat:=DefnPattern, _
                                   ReplaceWith:="$3")
  
   End If
  

End Sub



Function RegExpSubstitute(ReplaceIn, _
                          ReplaceWhat As String, _
                          ReplaceWith As String, _
                          Optional SubGlobal As Boolean = True, _
                          Optional RE As Object) As String
                         
     'Dim REX As Object
     If RE Is Nothing Then
        Set RE = CreateObject("vbscript.regexp")
     End If
  
   RE.Pattern = ReplaceWhat
   RE.Global = SubGlobal
   RegExpSubstitute = RE.Replace(ReplaceIn, ReplaceWith)
   
End Function

Function RegExpFind(FindIn As String, _
                    FindWhat As String, _
                    Optional IgnoreCase As Boolean = False) As Variant ' returns an array of all matches
       
    Dim i As Long
   
      Dim RE As Object
      Dim allMatches As Object, aMatch As Object
      Set RE = CreateObject("vbscript.regexp")
   
    RE.Pattern = FindWhat
    RE.IgnoreCase = IgnoreCase
    RE.Global = True
    Set allMatches = RE.Execute(FindIn)
    If allMatches.Count >= 1 Then
      ReDim rslt(0 To allMatches.Count - 1)
      For i = 0 To allMatches.Count - 1
          rslt(i) = allMatches(i).Value
          Next i
      RegExpFind = rslt
    End If
   
End Function