Attribute VB_Name = "HeatMap"

Sub HeatMap()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    

    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 10

    myHeight = 3

    myLeft = 100

    myTop = 100

        

    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count

    

    minValue = Application.WorksheetFunction.Min(ActiveCell.CurrentRegion)

    maxValue = Application.WorksheetFunction.Max(ActiveCell.CurrentRegion)

    

    'do colors

    For Each c In ActiveCell.CurrentRegion.Cells

        scaledValue = (c.Value - minValue) / (maxValue - minValue)

        Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

        myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

        If (scaledValue > 0.5) Then

            tmpShp.Fill.ForeColor.RGB = RGB(510 * (scaledValue - 0.5), 0, 0)

            Else

            tmpShp.Fill.ForeColor.RGB = RGB(0, 0, 255 - scaledValue * 510)

        End If

        tmpShp.Line.Visible = msoFalse

    Next c

    

    'group shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub





Sub HeatMapByRow()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    Dim c           As Range

    



    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 20

    myHeight = 10

    myLeft = 100

    myTop = 100



    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count



    For Each rw In ActiveCell.CurrentRegion.Rows

        minValue = Application.WorksheetFunction.Min(rw.EntireRow)

        maxValue = Application.WorksheetFunction.Max(rw.EntireRow)

        

        For Each c In rw.EntireRow.Cells

            If c.Value <> "" Then

                scaledValue = (c.Value - minValue) / (maxValue - minValue)

                Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

                myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

                If (scaledValue > 0.5) Then

                    tmpShp.Fill.ForeColor.RGB = RGB(510 * (scaledValue - 0.5), 0, 0)

                    Else

                    tmpShp.Fill.ForeColor.RGB = RGB(0, 0, 255 - scaledValue * 510)

                End If

                tmpShp.Line.Visible = msoFalse

            End If

        Next c

    Next rw

    

    'group shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub



Sub HeatMapRowOutliersRG()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    Dim c           As Range

    Dim userIn      As Integer

    



    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 20

    myHeight = 10

    myLeft = 100

    myTop = 100



    userIn = InputBox("Enter number of hi/low to exclude", "exclude...")

    userIn = userIn + 1

    

    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count



    For Each rw In ActiveCell.CurrentRegion.Rows

        minValue = Application.WorksheetFunction.Small(rw.EntireRow, userIn)

        maxValue = Application.WorksheetFunction.Large(rw.EntireRow, userIn)

        

        For Each c In rw.EntireRow.Cells

            If c.Value <> "" Then

                scaledValue = (c.Value - minValue) / (maxValue - minValue)

                scaledValue = Application.WorksheetFunction.Max(Application.WorksheetFunction.Min(scaledValue, 1), 0)

                Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

                myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

                If (scaledValue < 0.5) Then

                    tmpShp.Fill.ForeColor.RGB = RGB(scaledValue * 510, 255, 0)

                    Else

                    tmpShp.Fill.ForeColor.RGB = RGB(255, 255 - 255 * scaledValue, 0)

                End If

                tmpShp.Line.Weight = 0.25

                tmpShp.Line.DashStyle = msoLineSolid

                tmpShp.Line.Style = msoLineSingle

                tmpShp.Line.Visible = msoTrue

            End If

        Next c

    Next rw

    

    'group shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub



Sub HeatMapRowOutliers()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    Dim c           As Range

    Dim userIn      As Integer

    



    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 20

    myHeight = 3

    myLeft = 100

    myTop = 100



    userIn = InputBox("Enter number of hi/low to exclude", "exclude...")

    userIn = userIn + 1

    

    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count



    For Each rw In ActiveCell.CurrentRegion.Rows

        minValue = Application.WorksheetFunction.Small(rw.EntireRow, userIn)

        maxValue = Application.WorksheetFunction.Large(rw.EntireRow, userIn)

        

        For Each c In rw.EntireRow.Cells

            If c.Value <> "" Then

                scaledValue = (c.Value - minValue) / (maxValue - minValue)

                scaledValue = Application.WorksheetFunction.Max(Application.WorksheetFunction.Min(scaledValue, 1), 0)

                Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

                myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

                If (scaledValue < 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(scaledValue * 510, 0, 255)

                    ElseIf (scaledValue <= 0.75 And scaledValue >= 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(128, 0, 255 - 510 * (scaledValue - 0.25))

                    Else

                        tmpShp.Fill.ForeColor.RGB = RGB(128 + (scaledValue - 0.75) * 510, 0, 0)

                End If

                tmpShp.Line.Weight = 0.25

                tmpShp.Line.DashStyle = msoLineSolid

                tmpShp.Line.Style = msoLineSingle

                tmpShp.Line.Visible = msoTrue

            End If

        Next c

    Next rw

    

    'group shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub







Sub HeatMapColumnOutliers()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    Dim c           As Range

    Dim userIn      As Integer

    



    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 20

    myHeight = 3

    myLeft = 100

    myTop = 100



    userIn = InputBox("Enter number of hi/low to exclude", "exclude...")

    userIn = userIn + 1

    

    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count



    For Each clm In ActiveCell.CurrentRegion.Columns

        minValue = Application.WorksheetFunction.Small(clm.EntireColumn, userIn)

        maxValue = Application.WorksheetFunction.Large(clm.EntireColumn, userIn)

        

        For Each c In clm.EntireColumn.Cells

            If c.Value <> "" Then

                scaledValue = (c.Value - minValue) / (maxValue - minValue)

                scaledValue = Application.WorksheetFunction.Max(Application.WorksheetFunction.Min(scaledValue, 1), 0)

                Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

                myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

                If (scaledValue < 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(scaledValue * 510, 0, 255)

                    ElseIf (scaledValue <= 0.75 And scaledValue >= 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(128, 0, 255 - 510 * (scaledValue - 0.25))

                    Else

                        tmpShp.Fill.ForeColor.RGB = RGB(128 + (scaledValue - 0.75) * 510, 0, 0)

                End If

                tmpShp.Line.Weight = 0.25

                tmpShp.Line.DashStyle = msoLineSolid

                tmpShp.Line.Style = msoLineSingle

                tmpShp.Line.Visible = msoTrue

            End If

        Next c

    Next clm

    

    'group shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub



Sub HeatMapColumnMeanStd()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    Dim c           As Range

    Dim userIn      As Integer

    



    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 20

    myHeight = 3

    myLeft = 100

    myTop = 100



    'userIn = InputBox("Enter number of hi/low to exclude", "exclude...")

    'userIn = userIn + 1

    

    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count



    For Each clm In ActiveCell.CurrentRegion.Columns

        'minValue = Application.WorksheetFunction.Small(clm.EntireColumn, userIn)

        'maxValue = Application.WorksheetFunction.Large(clm.EntireColumn, userIn)

        meanValue = Application.WorksheetFunction.Average(clm.EntireColumn)

        stdValue = Application.WorksheetFunction.StDev(clm.EntireColumn)

        

        For Each c In clm.EntireColumn.Cells

            If c.Value <> "" Then

                scaledValue = (c.Value - meanValue) / stdValue

                scaledValue = (scaledValue + 1) / 2

                scaledValue = Application.WorksheetFunction.Max(Application.WorksheetFunction.Min(scaledValue, 1), 0)

                Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

                myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

                If (scaledValue < 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(scaledValue * 510, 0, 255)

                    ElseIf (scaledValue <= 0.75 And scaledValue >= 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(128, 0, 255 - 510 * (scaledValue - 0.25))

                    Else

                        tmpShp.Fill.ForeColor.RGB = RGB(128 + (scaledValue - 0.75) * 510, 0, 0)

                End If

                tmpShp.Line.Weight = 0.25

                tmpShp.Line.DashStyle = msoLineSolid

                tmpShp.Line.Style = msoLineSingle

                tmpShp.Line.Visible = msoTrue

            End If

        Next c

    Next clm

    

    'group shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub



Sub HeatMapColumnRow()

    Dim tmpShp      As Shape

    Dim shapeObject As Shape

    Dim scaledValue As Double

    Dim minValue    As Double

    Dim maxValue    As Double

    Dim width       As Integer

    Dim height      As Integer

    Dim numRows     As Integer

    Dim numCols     As Integer

    Dim myLeft      As Integer

    Dim myTop       As Integer

    Dim c           As Range

    Dim userIn      As Integer

    Dim mystart     As Range



    'Modify width and height of 'pixels' here, and location of picture

    myWidth = 20

    myHeight = 3

    myLeft = 100

    myTop = 100



    'userIn = InputBox("Enter number of hi/low to exclude", "exclude...")

    'userIn = userIn + 1

    

    'Don't change this

    numRows = ActiveCell.CurrentRegion.Rows.Count

    numCols = ActiveCell.CurrentRegion.Columns.Count



    Set mystart = ActiveCell.CurrentRegion.Cells(1, 1)





    For Each clm In ActiveCell.CurrentRegion.Columns

        meanValue = Application.WorksheetFunction.Average(clm.EntireColumn)

        stdValue = Application.WorksheetFunction.StDev(clm.EntireColumn)



        For Each c In clm.EntireColumn.Cells

            If c.Value <> "" Then

                c.Value = (c.Value - meanValue) / stdValue

            End If

        Next c

    Next clm



    For Each rw In ActiveCell.CurrentRegion.Rows

        minValue = Application.WorksheetFunction.Min(rw.EntireRow)

        maxValue = Application.WorksheetFunction.Max(rw.EntireRow)



        'MsgBox (minValue & ", " & maxValue)

        For Each c In rw.EntireRow.Cells

            If c.Value <> "" Then

                scaledValue = (c.Value - minValue) / (maxValue - minValue)

                scaledValue = Application.WorksheetFunction.Max(Application.WorksheetFunction.Min(scaledValue, 1), 0)

                Set tmpShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _

                myLeft + (myWidth * c.Column), myTop + (myHeight * c.Row), myWidth, myHeight)

                If (scaledValue < 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(scaledValue * 510, 0, 255)

                    ElseIf (scaledValue <= 0.75 And scaledValue >= 0.25) Then

                        tmpShp.Fill.ForeColor.RGB = RGB(128, 0, 255 - 510 * (scaledValue - 0.25))

                    Else

                        tmpShp.Fill.ForeColor.RGB = RGB(128 + (scaledValue - 0.75) * 510, 0, 0)

                End If

                tmpShp.Line.Weight = 0.25

                tmpShp.Line.DashStyle = msoLineSolid

                tmpShp.Line.Style = msoLineSingle

                tmpShp.Line.Visible = msoTrue

            End If

        Next c

    Next rw





    'Group Shapes

    blah = ActiveSheet.Shapes.SelectAll()

    Selection.Group

End Sub