Excel 2003 to 2010 code conversion help

[deletedalien]

So back in the Excel 2003 days where everything was soooo much simpler a user from this forum helped me create this amazing SICK code to create a graph report, but now it doesn't run in excel 2010 64 bit...

so is there a way that i can change this to actually run in 2010?

http://www.mrexcel.com/forum/members/pbornemeier.html

the code is supposed to be ran with this data:

and gets stuck on the yellow part.

Rep Name Call Started Duration h:mm:ss
Rep 1 2:19:18 PM 0:00:36
Rep 1 3:09:01 PM 0:00:56
Rep 1 3:11:01 PM 0:01:05
Rep 1 3:12:12 PM 0:01:13
Rep 1 3:26:26 PM 0:00:39
Rep 2 7:08:35 AM 0:01:57
Rep 2 7:16:32 AM 0:02:12
Rep 2 1:47:17 PM 0:02:01
Rep 3 7:05:01 AM 0:10:37
Rep 3 7:36:24 AM 0:00:16
Rep 3 11:41:43 AM 0:15:21
Rep 3 12:47:36 PM 0:00:46
Rep 3 1:45:36 PM 0:02:19
Rep 3 1:49:54 PM 0:00:32
Rep 3 1:51:46 PM 0:00:56
Rep 3 1:55:03 PM 0:00:35
Rep 3 1:59:26 PM 0:00:22
Rep 4 7:04:24 AM 0:00:16
Rep 4 2:40:41 PM 0:00:08
Rep 4 3:06:22 PM 0:02:16
Rep 4 3:21:35 PM 0:00:04
Rep 4 3:21:49 PM 0:03:05


and turn it in to an AWESOME horizontal scattered graph

so here is the code:

Option Explicit
Sub GraphReport()
    'With Headers in Row 1: Name, Call Started (formatted as hh:mm:ss), Call Duration (formatted as hh:mm:ss)
    'Data in rows 2 and below, with no blank lines
 
    Dim dDayStart As Date
    Dim dDayEnd As Date
    Dim sngX As Single
    Dim lLastDataRow As Long
    Dim lFirstGraphRow As Long
    Dim lCurrGraphRow As Long
    Dim lFirstGraphColumn As Long
    Dim dblPointsForOneHour As Double
    Dim sCurRepName As String
    Dim sngRightmostLine As Single
    Dim sngCurTop As Single
    Dim sngCurHeight As Single
    Dim iInCallColor As Integer
    Dim iOffCallColor As Integer
    Dim sngFirstLine As Single 'Leftmost line that can be drawn
    Dim sngLastLine As Single 'Rightmost line that can be drawn
    Dim iFirstTrackedHour As Integer
    Dim iLastTrackedHour As Integer
    Dim sngCheckPos As Single
    Dim dblPointsPerPixel As Double
    Dim iSpacing As Integer
    Dim bBoxLines As Boolean
    Dim bTimesVertical As Boolean
 
    'User settable options +++++++++++++++++++++++++++++++++++++++++++++
    'The leftmost column of the graph (>=5)
        lFirstGraphColumn = 6
    'The top bar of the graph will be in this row (>=3)
        lFirstGraphRow = 5
    'The horizontal width of 1 hour of the graph
        dblPointsForOneHour = 60
    'The color when in a call
        iInCallColor = 3 'Green
    'The color when not in a call
        iOffCallColor = 10 'Red
    'The first hour to display (0 to 23)
        iFirstTrackedHour = 5
    'The last hour to display (0 to 23 >= than iFirstTrackedHour)
        iLastTrackedHour = 17
    'Number of spaces between output graphs
        iSpacing = 0
    'Put boxes around each time period - may obscure short intervals
        bBoxLines = True 'True or False
    'Use vertical text for times
        bTimesVertical = False ' True/False
    'Width of the Names column in the output area will be
        'the same as the width of Column A
    '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
    'Some error correction
    If iSpacing < 0 Then iSpacing = 0
    If iSpacing > 10 Then iSpacing = 10
    If iFirstTrackedHour < 0 Then iFirstTrackedHour = 0
    If iLastTrackedHour > 23 Then iLastTrackedHour = 23
    If iFirstTrackedHour > iLastTrackedHour Then
        iFirstTrackedHour = 0
        iLastTrackedHour = 23
    End If
    If dblPointsForOneHour < 10 Then dblPointsForOneHour = 10
    If lFirstGraphColumn < 5 Then lFirstGraphColumn = 5
    If lFirstGraphRow < 3 Then lFirstGraphRow = 3
 
    'Delete existing shapes
    For sngX = ActiveSheet.Shapes.Count To 1 Step -1
        ActiveSheet.Shapes(sngX).Delete
    Next
 
    Columns(lFirstGraphColumn - 1).Clear 'Clear names column
 
    'Set output range column widths
    Columns(lFirstGraphColumn - 1).ColumnWidth = Columns(1).ColumnWidth
    SetRangeColumnWidth _
        Range(Cells(1, lFirstGraphColumn), _
        Cells(1, lFirstGraphColumn + iLastTrackedHour - iFirstTrackedHour)), _
        dblPointsForOneHour
 
    dDayStart = iFirstTrackedHour / 24
    dDayEnd = (iLastTrackedHour + 1) / 24
 
    sngFirstLine = Cells(lFirstGraphRow, lFirstGraphColumn).Left
    sngLastLine = sngFirstLine + (1 + iLastTrackedHour - iFirstTrackedHour) * dblPointsForOneHour
 
    'Draw Time Values
    For sngX = iFirstTrackedHour To iLastTrackedHour + 1 Step 0.5
        sngCheckPos = FindLinePos(CSng(sngX) / 24, dDayStart, dDayEnd, sngFirstLine, sngLastLine)
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngCheckPos - 13, Range("A" & lFirstGraphRow - 1).Top - 15, 30, 30).Select
        Selection.Placement = xlFreeFloating
        Selection.Characters.Text = Format(sngX / 24, "h:mm")
        With Selection.Characters(Start:=1).Font
            .Name = "Arial"
            .FontStyle = "Regular"
            .Size = 9
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
        End With
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .ReadingOrder = xlContext
            If bTimesVertical = True Then
                 .Orientation = xlUpward
            Else
                .Orientation = xlHorizontal
            End If
            .AutoSize = False
        End With
        Selection.ShapeRange.Fill.Visible = msoFalse
        Selection.ShapeRange.Line.Visible = msoFalse
 
    Next
 
    'Sort Data
    lLastDataRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1").Select
    Range("A1:C" & lLastDataRow).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range( _
        "B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase _
        :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
        DataOption2:=xlSortNormal
 
    'Draw graphs
    sCurRepName = Range("A2").Value
    lCurrGraphRow = lFirstGraphRow
    sngCurTop = Cells(lCurrGraphRow, lFirstGraphColumn).Top
    sngCurHeight = Cells(lCurrGraphRow, lFirstGraphColumn).Height
    sngRightmostLine = Cells(lCurrGraphRow, lFirstGraphColumn).Left
    Cells(lCurrGraphRow, lFirstGraphColumn - 1).Value = sCurRepName
 
    For sngX = 2 To lLastDataRow + 1
        If Cells(sngX, 1).Value <> sCurRepName Then
            sCurRepName = Cells(sngX, 1).Value
            DrawBox iOffCallColor, sngRightmostLine, sngCurTop, sngLastLine - sngRightmostLine, sngCurHeight, bBoxLines
            sngRightmostLine = sngFirstLine
            lCurrGraphRow = lCurrGraphRow + 1 + iSpacing
            sngCurTop = Cells(lCurrGraphRow, lFirstGraphColumn).Top
            sngCurHeight = Cells(lCurrGraphRow, lFirstGraphColumn).Height
            sngRightmostLine = Cells(lCurrGraphRow, lFirstGraphColumn).Left
            Cells(lCurrGraphRow, lFirstGraphColumn - 1).Value = sCurRepName
        End If
        If sCurRepName = "" Then Exit For
        sngCheckPos = FindLinePos(Cells(sngX, 2).Value, dDayStart, dDayEnd, sngFirstLine, sngLastLine)
        If sngCheckPos > sngRightmostLine Then
            DrawBox iOffCallColor, sngRightmostLine, sngCurTop, sngCheckPos - sngRightmostLine, sngCurHeight, bBoxLines
            sngRightmostLine = sngCheckPos
        Else
            MsgBox "Error: Multiple days seem to be present"
        End If
        sngCheckPos = FindLinePos(Cells(sngX, 2).Value + Cells(sngX, 3).Value, dDayStart, dDayEnd, sngFirstLine, sngLastLine)
        DrawBox iInCallColor, sngRightmostLine, sngCurTop, sngCheckPos - sngRightmostLine, sngCurHeight, bBoxLines
        sngRightmostLine = sngCheckPos
    Next
 
    Range("E2").Select
End Sub
Sub DrawBox(iColor As Integer, sngLeft As Single, sngTop As Single, sWidth As Single, sngHeight As Single, bOutline As Boolean)
    'Draw a solid colored box at the given position & size
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sWidth, sngHeight).Select
    Selection.Placement = xlFreeFloating
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = iColor
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Line.Visible = bOutline
End Sub
Function FindLinePos(dInput As Date, dFirstHour As Date, dLastHour As Date, sngFirstLine As Single, sngLastLine As Single) As Single
    'Return the horzontal position for dInput based on other inputs
    'No error checking is done.  dInput must be >= dFirstHour and <= dLastHour
    Dim sngbarwidth As Single
    sngbarwidth = sngLastLine - sngFirstLine
    FindLinePos = sngFirstLine + ((dInput - dFirstHour) / (dLastHour - dFirstHour)) * sngbarwidth
End Function
Function SetRangeColumnWidth(rngInput As Range, dblPoints As Double)
    'Set the column width for each column in rngInput to specific number of points
 
    Dim sngWidth As Single
    Dim rngOneCell As Range
    Dim dblIncrement As Double
    Dim lngIncrementCounter As Long
    Dim dblOldWidth As Double
 
    dblIncrement = 0.05
 
    Set rngOneCell = Cells(1, rngInput.Column)
    sngWidth = rngOneCell.Width
    If rngOneCell.Width > dblPoints Then rngOneCell.ColumnWidth = 1
    Do While rngOneCell.Width < dblPoints
        dblOldWidth = rngOneCell.ColumnWidth
        rngOneCell.ColumnWidth = rngOneCell.ColumnWidth + dblIncrement
        If dblOldWidth = rngOneCell.ColumnWidth Then dblIncrement = dblIncrement + 0.002
    Loop
    rngInput.ColumnWidth = rngOneCell.ColumnWidth
 
    Set rngOneCell = Nothing
 
End Function

any help will be GREATLY appreciated.

 

[sijpie]

just put a ' (comment mark) in front of the line and it should work. This is not a critical item.