building Heatmap

I need help on the following:

I have a set of data on various sites with their Zones & Clusters (refer data tab in attached file).

I am looking for a some kind of macro that would help me consolidate this data by clusters & Zones. Refer "Results" tab

There are certain calculations that need to be build such as Outage Minutes, no.of sites & Uptime%.

Once, I have the results tab,would like to build the heat map of clusters.Refer "Heatmap" tab. It may be through a command button.

Eg: All those clusters having uptime > 99.90 from Results tab, should lined up against it. 3 examples are shown in the tab…

Patna has uptime of 99.70 and therefore is appearing against 99.85-99.65 group

I need to line up all the clusters according to the uptime achieved, lined up against grouped uptime.

looking forward to your inputs...

Thanks in advance.

No body has yet replied to my query...Can someone look into this urgently??

This feature of heat map is available in excel 2007. I am using excel 2003 and hence need to achieve the same through some macro..

kindly help on this...

Thanks & Regards

This code get data from data sheet and put data in result and heatmap sheet.
I hope it can help you.

Sub Macro1()
   Dim heatMapSh As Worksheet
   Dim resultSh As Worksheet
   Dim dataSh As Worksheet
   Dim lastRow As Long, myRow As Long
   Dim hmLastrow As Long
   Dim r As Long, r2 As Long
   Dim myKey As String, keysNum As Long
   Dim elem As Variant
   Dim myText As String
   Dim fromValue As Single, toValue As Single
   Dim myValue As Single, cluster As String
   Dim destRow As Long, destCol As Integer
   
   Dim dic1 As Object
   Dim dic2 As Object
   
   Set heatMapSh = ThisWorkbook.Sheets("heatmap")
   Set resultSh = ThisWorkbook.Sheets("result")
   Set dataSh = ThisWorkbook.Sheets("data")
   
   Set dic1 = CreateObject("scripting.dictionary")
   Set dic2 = CreateObject("scripting.dictionary")
   
   'read data sheet for unique circle + cluster and zone
   For r = 2 To dataSh.UsedRange.Rows.Count
      myKey = dataSh.Cells(r, "a") & "," & dataSh.Cells(r, "e")
      If Not dic1.exists(myKey) Then
         dic1.Add Item:="", key:=myKey
      End If
   
      myKey = dataSh.Cells(r, "d")
      If Not dic2.exists(myKey) Then
         dic2.Add Item:="", key:=myKey
      End If
   Next r
   
   
   'put data on result sheet
   resultSh.Range("2:" & Rows.Count).ClearContents
   
   myRow = 1
   For Each elem In dic1.keys
      myRow = myRow + 1
      resultSh.Cells(myRow, "a") = Split(elem, ",")(0)
      resultSh.Cells(myRow, "b") = Split(elem, ",")(1)
   Next elem
   resultSh.Range("c2:c" & myRow).Formula = "=SUMIF(Data!$E:$E,Result!B2,Data!$C:$C)"
   resultSh.Range("d2:d" & myRow).Formula = "=COUNTIF(Data!E:E,Result!B2)"
   resultSh.Range("e2:e" & myRow).Formula = "=((1440*31*D2)-C2)/(1440*31*D2)*100"
   lastRow = myRow
   
   myRow = 1
   For Each elem In dic2.keys
      myRow = myRow + 1
      resultSh.Cells(myRow, "g") = elem
   Next elem
   resultSh.Range("h2:h" & myRow).Formula = "=SUMIF(Data!D:D,Result!G2,Data!C:C)"
   resultSh.Range("i2:i" & myRow).Formula = "=COUNTIF(Data!D:D,G2)"
   resultSh.Range("j2:j" & myRow).Formula = "=((1440*31*I2)-H2)/(1440*31*I2)*100"

   'put data on heatmap sheet
   With heatMapSh.Range("d:d").Resize(, Columns.Count - 4)
      .ClearContents
      .Interior.ColorIndex = xlNone
   End With
   hmLastrow = heatMapSh.Cells(Rows.Count, "b").End(xlUp).Row
   For r = 2 To lastRow
      myValue = Round(resultSh.Cells(r, "e"), 2)
      cluster = resultSh.Cells(r, "b")
      
      For r2 = 3 To hmLastrow
         If Trim(heatMapSh.Cells(r2, "b")) <> "" Then
            myText = heatMapSh.Cells(r2, "b")

            If heatMapSh.Cells(r2, "b") Like "*<*" Then
               fromValue = Evaluate(Mid(myText, 2))
               If myValue < fromValue Then
                  destRow = r2
                  Exit For
               End If
            ElseIf heatMapSh.Cells(r2, "b") Like "*>*" Then
               fromValue = Evaluate(Mid(myText, 2))
               If myValue > fromValue Then
                  destRow = r2
                  Exit For
               End If
            ElseIf heatMapSh.Cells(r2, "b") Like "*-*" Then
               sep = InStr(myText, "-")
               toValue = Evaluate(Left(myText, sep - 1))
               fromValue = Evaluate(Mid(myText, sep + 1))
               If myValue >= fromValue And myValue <= toValue Then
                  destRow = r2
                  Exit For
               End If
            End If
         End If
      Next r2
       
      With heatMapSh
         destCol = .Cells(destRow, Columns.Count).End(xlToLeft).Column + 1
         If destCol < 4 Then destCol = 4
         .Cells(destRow, destCol) = cluster
         .Cells(destRow, destCol).Interior.ColorIndex = .Cells(destRow, "b").Interior.ColorIndex
         .Cells(destRow, destCol).Font.Size = 8
      End With
   Next r
   heatMapSh.Range("d:d").Resize(, Columns.Count - 3).Columns.AutoFit
End Sub

Regards,
Antonio

Thanks for your reply...but I am facing some error while executing the macro...

error is attached with the mail..kindly help to rectify the same...

thanks...