How do I make this type of chart??

[gcefaloni]

Hi, I would like to recreate this type of chart. I have a big table with 1s and -1s. Sectors and dates are my 2 axes. I would like each sector to be on Y axis and dates to be on X axis. If the value for a given sector at a given point in time is a 1, then have the bar in blue and if it is a -1, then have the bar in red.

Also, what is this kind of chart even called??

Thanks!!

 

[pbornemeier]

I would call it an interrupted bar chart.
This site:

You searched for bar chart - Peltier Tech

peltiertech.com

Has a huge number of charts. I did not see one there that was exactly what you have, but check it out.
I made a display something like that, but it was through much code and not a "real" chart. It drew a series of blocks on a worksheet.
Please provide some of the data you want to plot and I will see if I can adapt/recreate my old code.
What is the smallest time division on the date chart? It appears to be about 1 month.

 

[gcefaloni]

Hi Phil, thanks a lot for the initial thoughts.

The smallest time division is 1 week. Here is a spreadsheet with different ways of showing the same data.. I've tried with allocation percentages, 1 or -1 as I had discussed in the email, True or False, trying to show it as a duration similar to a gantt chart.. no success for now. But here is the spreadsheet so that you can play around with it. Ideally, the 1 or -1 dataset would be used.

Link: Dropbox Link spreadsheet

Date	es	nq	pt	ty	us	cn	dx	gc	cl	fv
2017-01-02			1	1	1			-1	1
2017-01-09		1		1	-1	1		-1
2017-01-16	1	-1	1		1			1
2017-01-23		1	1	1	1			-1
2017-01-30	1	1	-1						-1	1
2017-02-06	1	1		1				-1	1
2017-02-13	1	1	-1		1			-1
2017-02-20	1	1	1				1	1
2017-02-27	1	1			-1	1		1
2017-03-06	1	-1			-1	1	1
2017-03-13	1	-1	1				1			1
2017-03-20	1	1		1				1		1
2017-03-27				1	-1	1		1		1
2017-04-03				1	-1	1		1	-1
2017-04-10		1	1			1	1		-1
2017-04-17				1	-1	1		1	1
2017-04-24	1	-1	1		1			1
2017-05-01	1	-1	-1			1				1
2017-05-08	1	-1	-1			1				1
2017-05-15	1	-1	-1						1	1
2017-05-22		1		1	1			1	1
2017-05-29		1			1	1		-1	1
2017-06-05	1	-1			1			-1	1
2017-06-12	1		-1	1	-1	1
2017-06-19	1			1	-1		1			1
2017-06-26	1	-1		1	-1					1
2017-07-03	1		1				1		1	1
2017-07-10	1			1			1		1	1
2017-07-17	1	-1	1	1					1
2017-07-24	1	-1			1			1	1
2017-07-31	1	-1			1			1	1
2017-08-07	1	-1	1					1	1
2017-08-14				1	-1	1		1		1
2017-08-21				1	-1	1		1		1
2017-08-28	1		1	1	-1			1
2017-09-04	1	-1	1		1			1
2017-09-11	1	-1		1	1			1
2017-09-18	1	-1	1		1				1
2017-09-25	1	-1	1				1		1
2017-10-02	1		1			1	1		-1
2017-10-09	1	-1	-1			1	1
2017-10-16
2017-10-23	1	-1	1			1			-1
2017-10-30	1	-1	1				1		-1
2017-11-06		1	1		1		1		-1
2017-11-13		1	1		1			1	-1
2017-11-20		1	1			1		1	-1
2017-11-27	1	-1			1			1	-1
2017-12-04	1	-1	1		1				-1
2017-12-11	1		1		1	1	1
2017-12-18	1	-1	1		1		1
2017-12-25	-1	1	1						-1	1
2018-01-01	1		1					1	1	1
2018-01-08	1	-1	1					1	-1
2018-01-15	1	-1	1					1	1
2018-01-22	1	-1	1			1			1
2018-01-29	1	-1						1	1	1
2018-02-05				1		1		-1	1	1
2018-02-12				1		1	1	1		1
2018-02-19		1				1	1	1		1
2018-02-26	-1	1	1					1	1
2018-03-05		1		1	-1	1	1
2018-03-12	1	-1			1	1	1
2018-03-19	-1	1	1		1				1
2018-03-26				1	-1	1		1	1
2018-04-02				1	-1			1	1	1
2018-04-09	1		1		1	1	1
2018-04-16	1	-1						1	-1	1
2018-04-23	-1	1	1				1		1
2018-04-30	1	-1	1				1		1
2018-05-07		1	1		1		1		1
2018-05-14	1	-1	1				1		1
2018-05-21	1	-1	1				1		1
2018-05-28				1	-1	-1	1			1
2018-06-04	1	-1		1	-1	1
2018-06-11	1	-1	1		-1	1
2018-06-18	1	-1	1			1	1
2018-06-25			1		1	1	1		-1
2018-07-02			1	1	-1	1			-1
2018-07-09	1			1	-1				1	1
2018-07-16	1	-1			1	1
2018-07-23	1	-1	1				1			1
2018-07-30	1		1				1		-1	1
2018-08-06	1	-1	1				1		-1
2018-08-13	1	-1		1	-1		1
2018-08-20	1			1	-1	1	1
2018-08-27	1	-1			1	1			-1
2018-09-03	1	-1				1		1	-1
2018-09-10	1	-1				1	1			1
2018-09-17	1						1	1	-1	1
2018-09-24	1	-1	1					1	1
2018-10-01	1	-1					1		1	1
2018-10-08				1			1	1	1	1
2018-10-15				1		-1	1	1		1
2018-10-22				1	-1	1	1	1
2018-10-29				1	-1	1	1	1
2018-11-05				1		-1	1	1		1
2018-11-12	-1	-1	1				1			1
2018-11-19			1	1	-1	1				1
2018-11-26				1	-1	1		1		1
2018-12-03	1	-1	1			1		1
2018-12-10		1			1	1		1	1
2018-12-17				1	-1	1		1	1
2019-01-07	1	-1	1					1	-1
2019-01-14	1	-1	1					1	-1
2019-01-21	-1	-1	1				1		-1
2019-01-28	1	-1	1					1	1
2019-02-04	1	-1	1		1			1
2019-02-11	1	-1	1		1		1
2019-02-18	1	-1	1				1		-1
2019-02-25	1	-1	1					1	-1
2019-03-04	-1	1	1				1		1
2019-03-11			1	1		-1	1			1
2019-03-18		1		1	-1	1			1
2019-03-25	1	1			1			1	1
2019-04-01	1	-1		1	1				1
2019-04-08	-1	1	1				1		1
2019-04-15	-1	1	1				1		1
2019-04-22	-1	1	1				1		1
2019-04-29	1	-1	1			1	1
2019-05-06				1	-1		1	1		1
2019-05-13				1	-1	1		1		1
2019-05-20				1	-1		1		1	1
2019-05-27				1	-1	-1	1			1
2019-06-03				1	-1	1		-1		1
2019-06-10	1	-1		1	1			-1
2019-06-17	1	-1	1	1				1
2019-06-24	1	-1	1					1	-1
2019-07-08	1	-1			1		1	1
2019-07-15	1	-1	1				1		1
2019-07-22		1			-1	1		-1		1
2019-07-29		1			-1	1	1	1
2019-08-05				1	-1	1		1		1
2019-08-12				1	-1	1		1		1
2019-08-19				1	-1	1		1		1
2019-08-26				1	-1			1	1	1
2019-09-02	1		-1		1		1	1
2019-09-09	1	-1	1				1		1
2019-09-16	1	-1	1				1		1
2019-09-23	-1		1				1	1	-1
2019-09-30				1	-1	1	1			1
2019-10-07				1	-1	1	1			1
2019-10-14	1	-1		-1			1			1
2019-10-21	-1	1	1						1	1
2019-10-28	1	-1	1					1	-1
2019-11-04	1	-1	1					1	-1
2019-11-11	1	-1	1				1		1
2019-11-18	1	-1	1				1		1
2019-11-25	1		1	1	-1				1
2019-12-02	1	-1			1	1	1
2019-12-09	1	-1	1						1	1
2019-12-16	1	-1	1					1	1
2020-01-06				1	-1	1		1	1
2020-01-13	1	-1	1				1	1
2020-01-20	1	-1	1				1	1
2020-01-27			1	1	-1	-1		1
2020-02-03				1	-1	1		1		1
2020-02-10	1	-1		1	-1		1
2020-02-17	-1	-1	1				1	1
2020-02-24				1	-1	1		1	1
2020-03-02				1	-1	1		1		1
2020-03-09				1	-1	1		-1		1
2020-03-16				-1	-1	1	1			1
2020-03-23				1	-1	1	1			1
2020-03-30				1	-1	1		1		1
2020-04-06	1	1	-1					1	1
2020-04-13	1	1	-1					1	1
2020-04-20	1	-1	-1			1		1
2020-04-27	1	1	-1		1	1
2020-05-04			1	1	-1	1		1
2020-05-11	-1	1	1						-1	1
2020-05-18	-1	1	1					1	-1
2020-05-25	-1	1	1					1	-1
2020-06-01	-1	1	1			1			-1
2020-06-08	-1	1	1						1	1
2020-06-15		-1		1	-1	1				1
2020-06-22		1		1	-1	1		-1
2020-06-29		1		1	1			1	1
2020-07-06	-1	-1	1					1	1
2020-07-13	-1	1	1					1	-1
2020-07-20	1	-1	1		1			1
2020-07-27	1		1		1			1	-1
2020-08-03	1	-1		1	1			1
2020-08-10	1	-1	1					1	-1
2020-08-17	1	-1	1					1	-1
2020-08-24	1	-1	1						-1	1
2020-08-31	1	-1	1					1	-1
2020-09-07	1			1		-1	1			1
2020-09-14				1	-1	-1	1			1
2020-09-21				1	-1	1	1		1
2020-09-28	1	-1	1				1		1
2020-10-05	1	-1	-1			1	1
2020-10-12	1	-1	1					1	1
2020-10-19	1	-1	1					1	1
2020-10-26				1	-1	1	1			1
2020-11-02				1		-1	1	1		1
2020-11-09	-1	1	1						1	1
2020-11-16	-1	1	1						-1	1
2020-11-23	-1		1		1				-1	1
2020-11-30	1	-1	1		1				-1

 

[pbornemeier]

At the year boundary, how do you determine which week belongs to which year?
You are using Monday Dates. Does a mark in 2020-11-30 reflect the 7 days ending with 11/30 or the 7 days starting with 11/30, or something else?

 

[gcefaloni]

At the year boundary, how do you determine which week belongs to which year?
You are using Monday Dates. Does a mark in 2020-11-30 reflect the 7 days ending with 11/30 or the 7 days starting with 11/30, or something else?

They reflect the 5 working days of the prior week. Weekends have no activity but are still included in the 7 days.. the changes in allocation are made on monday morning for the coming week and do not include the monday itself.

 

[pbornemeier]

Add this to a module in a new workbook
Run the 'PrepareBlankWorkbook' code
Add your data to the 'Data' worksheet
Click 'Verify & Plot' button on the 'Main' worksheet

Let me know how it works for you and if any changes are needed.

Option Explicit
'Interrupted Bar Chart
'Copy this module to a blank workbook

Sub PrepareBlankWorkbook()
    'Run this code in a blank workbook
    'This code will delete the 'Data' & 'Main' worksheets
    
    On Error Resume Next
    Debug.Print Worksheets("Data").Range("A1")
    If Err.Number = 0 Then
        Select Case MsgBox("Initialize Workbook ?", vbOKCancel + vbDefaultButton2)
        Case vbOK
        Case Else: GoTo End_Sub
        End Select
    End If
        
    'Remove worksheets (that are probably not there)
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Data").Delete
    Worksheets("Main").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    'Add worksheets
    Worksheets.Add(before:=Sheets(1)).Name = "Data"
    Worksheets.Add(before:=Sheets(1)).Name = "Main"
    
    'Add items to 'Main'
    With Worksheets("Main")
        .Range("A1").Resize(7, 1) _
            .Value = Application.Transpose(Array("Date Min", "Plot Min", _
            "Plot Max", "Date Max", "Plot Width", "Block Height", "Y-Axis Title"))
        .Columns.AutoFit
        .Range("B7").Value = "Y-Axis Title"
        .Activate
        .Buttons.Add(210.75, 27, 125, 31.5).Select
        With Selection
            .OnAction = "ParseDataUpdateMainWithResults"
            .Characters.Text = "Verify & Plot"
            .Placement = xlFreeFloating
        End With
        
        .Buttons.Add(450, 27, 125, 31.5).Select
        With Selection
            .OnAction = "SetMaxPlotValues"
            .Characters.Text = "Set Max Plot Values"
            .Placement = xlFreeFloating
        End With
        
        With .Range("B2:B3,B5:B6")
            With .Borders
                .LineStyle = xlContinuous
            End With
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 16764057
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End With
        
        .Range("C1").Select
    End With
    
    'Sample data to 'Data'
    With Worksheets("Data")
        .Range("A1").Resize(1, 11).Value = Array("Date", "es", "nq", "pt", "ty", "us", "cn", "dx", "gc", "cl", "fv")
        .Range("A2").Resize(1, 11).Value = Array("1/2/2017", "", "", "1", "1", "1", "", "", "-1", "1", "")
        .Range("A3").Resize(1, 11).Value = Array("1/9/2017", "", "1", "", "1", "-1", "1", "", "-1", "", "")
        .Range("A4").Resize(1, 11).Value = Array("1/16/2017", "1", "-1", "1", "", "1", "", "", "1", "", "")
        .Range("A5").Resize(1, 11).Value = Array("1/23/2017", "", "1", "1", "1", "1", "", "", "-1", "", "")
        .Range("A6").Resize(1, 11).Value = Array("1/30/2017", "1", "1", "-1", "", "", "", "", "", "-1", "1")
    End With
    
    Worksheets("Data").Activate
    Worksheets("Data").UsedRange.Columns.AutoFit
    
    MsgBox "Replace the sample data on the 'Data' worksheet with your data" & vbLf & vbLf & _
        "Monday dates in cell A2 and below" & vbLf & _
        "Series Names in Cell B1 and right" & vbLf & _
        "Data (+1, -1, null) at the intersecting cells", , "Update Data Worksheet"
        
End_Sub:

End Sub

Sub SetMaxPlotValues()

    With Worksheets("Main")
        .Range("B2").Value = .Range("B1").Value
        .Range("B3").Value = .Range("B4").Value
    End With
    
End Sub
Sub ParseDataUpdateMainWithResults()

    Dim dteDataMax As Date      'Largest Date in Data
    Dim dteDataMin As Date      'Smallest Date in Data
    Dim dteGraphMax As Date     'Last Date on Graph
    Dim dteGraphMin As Date     'First Date on Graph

    Dim lSeriesCount As Long
    Dim lLastDataSeriesColumn As Long
    Dim lLastDataSeriesRow As Long
    Dim lLastDataRow As Long
    Dim bChanged As Boolean
    Dim bBadValues As Boolean
    Dim sOutput As String
    Dim sPartial As String
    Dim sngDefaultPlotWidth As Single
    Dim sngDefaultBlockHeight As Single
    Dim varEnteredPlotWidth As Variant
    Dim varEnteredBlockHeight As Variant
    Dim bBadPWValue As Boolean
    Dim bBadBHValue As Boolean
    Dim lPartialWeeks As Long
    Dim lMessageMark As Long
    
    sngDefaultPlotWidth = 600
    sngDefaultBlockHeight = 16
    
    With Worksheets("Data")
        .AutoFilterMode = False
        dteDataMax = Application.WorksheetFunction.Max(.Columns(1))
        dteDataMin = Application.WorksheetFunction.Min(.Columns(1))
        lLastDataSeriesColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lLastDataSeriesRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        lSeriesCount = lLastDataSeriesColumn - 1
        lLastDataRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    With Worksheets("Main")
        .Range("B1:B6").Interior.Color = xlNone
        .Range("B2:B3,B5:B6").Interior.Color = 16764057
        .Range("B1").Value = dteDataMin
        .Range("B4").Value = dteDataMax
        If .Range("B2").Value = vbNullString Then .Range("B2").Value = dteDataMin
        If .Range("B3").Value = vbNullString Then .Range("B3").Value = dteDataMax
        If .Range("B5").Value = vbNullString Then .Range("B5").Value = sngDefaultPlotWidth
        If .Range("B6").Value = vbNullString Then .Range("B6").Value = sngDefaultBlockHeight
        If (.Range("B1").Value <> .Range("B2").Value) Or (.Range("B3").Value <> .Range("B4").Value) Then
            dteGraphMin = .Range("B2").Value
            dteGraphMax = .Range("B3").Value
            bChanged = True
        Else
            .Range("B2").Value = dteDataMin
            .Range("B3").Value = dteDataMax
        End If
        
        .Columns.AutoFit
        
        varEnteredPlotWidth = .Range("B5").Value
        varEnteredBlockHeight = .Range("B6").Value
        
        If .Range("B1").Value > dteDataMin Then .Range("B1").Interior.Color = vbRed: bBadValues = True
        If .Range("B4").Value < dteDataMax Then .Range("B4").Interior.Color = vbRed: bBadValues = True
        
        If .Range("B2").Value < .Range("B1").Value Then .Range("B2").Interior.Color = vbRed: bBadValues = True
        If .Range("B3").Value < .Range("B2").Value Then .Range("B3").Interior.Color = vbRed: bBadValues = True
        If .Range("B4").Value < .Range("B3").Value Then .Range("B4").Interior.Color = vbRed: bBadValues = True
        
        'Max/Min Values for Plot Width
        If .Range("B5").Value < 50 Then .Range("B5").Value = sngDefaultPlotWidth: .Range("B5").Interior.Color = vbRed: bBadValues = True: bBadPWValue = True
        If .Range("B5").Value > 2000 Then .Range("B5").Value = sngDefaultPlotWidth: .Range("B5").Interior.Color = vbRed: bBadValues = True: bBadPWValue = True
        
        'Max/Min Values for Week-Block height
        If .Range("B6").Value < 4 Then .Range("B6").Value = sngDefaultBlockHeight: .Range("B6").Interior.Color = vbRed: bBadValues = True: bBadBHValue = True
        If .Range("B6").Value > 100 Then .Range("B6").Value = sngDefaultBlockHeight: .Range("B6").Interior.Color = vbRed: bBadValues = True: bBadBHValue = True
        
        lPartialWeeks = DateDiff("w", .Range("B2").Value, .Range("B3").Value) + 1
        If (.Range("B1").Value <> .Range("B2").Value) Or (.Range("B3").Value <> .Range("B4").Value) Then
            sPartial = "You have chosen to plot a subset of data (" & lPartialWeeks & " weeks) " & vbLf & _
            "ranging from " & .Range("B2").Value & " to " & .Range("B3").Value & "." & vbLf & vbLf
            lMessageMark = vbInformation
        End If
        
    End With
    
    If bBadValues Then
        MsgBox "B1 is the calculated value of the earliest date on the Data worksheet" & vbLf & vbLf & _
         "B2 is the manually entered value of the earliest date to plot. " & vbLf & _
         "   It must be greater than B1 and less than B3." & vbLf & vbLf & _
         "B3 is the manually entered value of the latest date to plot" & vbLf & _
         "   It must be greater than B2 and less than B4." & vbLf & vbLf & _
         "B4 is the calculated value of the latest date on the Data worksheet" & vbLf & vbLf & _
         "B5 is the width of the plot area in pixels.  The entered value of " & varEnteredPlotWidth & " is reset to the default value of " & sngDefaultPlotWidth & "." & vbLf & vbLf & _
         "B6 is the height of the blue/red blocks.  The entered value of " & varEnteredBlockHeight & " is reset to the default value of " & sngDefaultBlockHeight & ".", vbCritical, _
         "Setup Entry Error Exist"
        
    Else
        If bChanged Then
            sOutput = "If you want to change the plot range, click 'Cancel' & adjust the 'Plot Min' and/or 'Plot Max' values for the desired range."
        Else
            sOutput = "If you want to plot less that then full date range, increase the 'Plot Min' and/or " & _
            "decrease the 'Plot Max' values."
        End If
        
        Select Case MsgBox(sPartial & "Data worksheet has " & lSeriesCount & " data series " & _
            "with " & lLastDataSeriesRow & " weeks of data " & vbLf & _
            "ranging from " & dteDataMin & " to " & dteDataMax & "." & vbLf & vbLf & _
            sOutput & vbLf & vbLf & _
            "If you want to change the plot dimensions, click 'Cancel' & modify the 'Plot Width' to change the width " & _
            "of the plot and/or 'Block Height' to change the height of the blue/red week-blocks.", vbOKCancel + lMessageMark, _
            "Ready to Plot with Current Values")
        Case vbOK
            BuildChartAndGraphData
        End Select
    End If
End Sub

Sub BuildChartAndGraphData()
    'https://www.mrexcel.com/board/threads/how-do-i-make-this-type-of-chart.1155425/

    Const lColorPlus As Long = rgbBlue
    Const lColorMinus As Long = rgbRed
    
    Dim rngULCell As Range
    Dim dteDataMax As Date      'Largest Date in Data
    Dim dteDataMin As Date      'Smallest Date in Data
    Dim dteGraphMax As Date     'Last Date on Graph
    Dim dteGraphMin As Date     'First Date on Graph
    Dim sngFirstMonth As Single
    Dim sngLastMonth As Single
    Dim sngMaxPlotWidth As Single
    Dim sngLeft As Single
    Dim sngWidth As Single
    Dim sngTop As Single
    Dim sngPlotRowHeight As Single
    Dim sngWeekWidth As Single
    Dim sngDateSpanWidth As Single
    Dim sngInitColumnWidth As Single
    Dim lDateRow As Long
    Dim sngWidthToColumnWidthRatio As Single
    Dim lSeriesCount As Long
    Dim lLastDataSeriesColumn As Long
    Dim lDataSeriesColumnIndex As Long
    Dim dteFirstMonth As Date
    Dim dteLastMonth As Date
    Dim lQuarterCount As Long
    Dim rngDateRow As Range
    Dim sngPlotWidth As Single
    Dim lFirstDateColumn As Long
    Dim lLastDateColumn As Long
    Dim lColIndex As Long
    Dim lQuarterIndex As Long
    Dim dteFirstCell As Date
    Dim lLastRow As Long
    Dim lLastDataRow As Long
    Dim lDataRowIndex As Long
    Dim bSkip As Boolean
    Dim lColor As Long
    Dim sngNameWidth As Single
    Dim dteSpanDateFirst As Date
    Dim dteSpanDateAfterLast As Date
    Dim sngSpanDays As Single
    Dim dteQtr As Date
    Dim dteDataDate As Date
    Dim sngSpanLeft As Single
    Dim sngWeekBlockHeight As Single
    Dim shp As Shape
    Dim sngTitleWidth As Single
    
    sngPlotWidth = Worksheets("Main").Range("B5").Value
    sngWeekBlockHeight = 16      'Height of graph blocks
    Set rngULCell = Worksheets("Main").Range("F10") 'Top left corner of graph (Holds first category name)
    
    With Worksheets("Data")
        .AutoFilterMode = False
        dteDataMax = Application.WorksheetFunction.Max(.Columns(1))
        dteDataMin = Application.WorksheetFunction.Min(.Columns(1))
        lLastDataSeriesColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lSeriesCount = lLastDataSeriesColumn - 1
        lLastDataRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    With Worksheets("Main")
        For Each shp In .Shapes
            If InStr(shp.Name, "Button") = 0 Then shp.Delete
        Next
        dteGraphMax = .Range("B3").Value
        dteGraphMin = .Range("B2").Value
        .UsedRange.Columns.ColumnWidth = 8.43
        .Columns(1).AutoFit
        .Columns(2).ColumnWidth = 10
        .Columns(3).ColumnWidth = 3
        
        'Determine ColumnWidth to Width Ratio
        With rngULCell
            sngInitColumnWidth = .ColumnWidth
            .ColumnWidth = 255
            sngWidthToColumnWidthRatio = 255 / .Width    '~ 0.1899441
            .Columns.AutoFit
        End With
        
        'Reset Plot Area
        With Worksheets("Main")
            lLastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
            If lLastRow > rngULCell.Row Then
                With Worksheets("Main").Range(.Cells(rngULCell.Row, 1), .Cells(lLastRow, 1)).EntireRow
                    .MergeCells = False
                    .ClearContents
                    .Borders.LineStyle = xlNone
                    .Rows.AutoFit
                End With
            End If
        End With
    End With
    
    'Copy Series Names from Data
    With Worksheets("Data")
        .Range(.Range("B1"), .Range("B1").End(xlToRight)).Copy
    End With
    With Sheets("Main")
        rngULCell.PasteSpecial Paste:=xlPasteAll, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        rngULCell.CurrentRegion.RowHeight = sngWeekBlockHeight * 2
        rngULCell.EntireColumn.ColumnWidth = 100    'So names don't wrap
        rngULCell.EntireColumn.AutoFit
        sngNameWidth = rngULCell.ColumnWidth / sngWidthToColumnWidthRatio
        sngTitleWidth = rngULCell.Offset(0, -1).ColumnWidth / sngWidthToColumnWidthRatio
        lDateRow = rngULCell.CurrentRegion.Rows.Count + 10
        With Selection.Offset(0, -1)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
            .Orientation = 90
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
            .Value = Sheets("Main").Range("B7").Value
            .Borders(xlEdgeRight).LineStyle = xlContinuous
        End With
        With rngULCell.CurrentRegion
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
        End With
        
    End With
    
    'Determine Column Width & Date Labels
    lQuarterCount = DateDiff("q", dteGraphMin, dteGraphMax, , vbFirstFourDays) + 1
    With Worksheets("Main")
        'Range that holds the dates
        Set rngDateRow = .Range(.Cells(lDateRow, rngULCell.Column + 1), .Cells(lDateRow, rngULCell.Column + (3 * lQuarterCount)))
        
        rngDateRow.ColumnWidth = sngWidthToColumnWidthRatio * (sngPlotWidth - sngNameWidth - sngTitleWidth) / (lQuarterCount * 3)
        
        lFirstDateColumn = rngULCell.Column + 1
        lLastDateColumn = rngULCell.Column + rngDateRow.Cells.Count
        For lColIndex = lFirstDateColumn To lLastDateColumn Step 3
            lQuarterIndex = lQuarterIndex + 1
            With .Range(.Cells(lDateRow, lColIndex), .Cells(lDateRow, lColIndex + 2))
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = True
                .ReadingOrder = xlContext
                .MergeCells = True
                dteQtr = DateSerial(Year(dteGraphMin), Month(dteGraphMin) + (3 * (lQuarterIndex - 1)), 1)
                .Value = dteQtr
                .NumberFormat = "mmm-yy"
            End With
            If lQuarterIndex = 1 Then dteSpanDateFirst = dteQtr
        Next
        dteSpanDateAfterLast = DateAdd("q", 1, dteQtr)
        
        'Iteration to reduce size of plot area columns to get total width below specified value
        Do While rngULCell.CurrentRegion.Width > sngPlotWidth
            'Debug.Print rngDateRow.ColumnWidth, rngULCell.CurrentRegion.Width
            rngDateRow.ColumnWidth = rngDateRow.ColumnWidth * 0.9
        Loop
        
            
        With rngDateRow.Borders
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        
        'Determine width of a week
        sngDateSpanWidth = rngDateRow.Width
        sngSpanDays = dteSpanDateAfterLast - dteSpanDateFirst
        sngWeekWidth = 7 * sngDateSpanWidth / sngSpanDays
        sngSpanLeft = .Cells(1, lFirstDateColumn).Left
        
    End With
    
    'Graph Data
    Application.StatusBar = "0%"
    For lDataSeriesColumnIndex = 2 To lLastDataSeriesColumn
        
        With Worksheets("Main").Cells(rngULCell.Row - 2 + lDataSeriesColumnIndex, rngULCell.Column)
            sngTop = .Top + (.Height / 4)
        End With
        
        Application.ScreenUpdating = False
        For lDataRowIndex = 2 To lLastDataRow
            bSkip = False
            dteDataDate = Worksheets("Data").Cells(lDataRowIndex, 1).Value
            If dteDataDate >= dteGraphMin And dteDataDate <= dteGraphMax Then
            
                Select Case Worksheets("Data").Cells(lDataRowIndex, lDataSeriesColumnIndex).Value
                Case 1: lColor = lColorPlus
                Case -1: lColor = lColorMinus
                Case Else
                    bSkip = True
                End Select
                
                'Calculate week block position
                sngLeft = sngSpanLeft + (sngDateSpanWidth * ((dteDataDate - dteSpanDateFirst) / sngSpanDays))
                
                
                If Not bSkip Then
                    'LTWH
                    ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sngWeekWidth, sngWeekBlockHeight).Select
                    Selection.ShapeRange.Line.Visible = msoFalse
                    With Selection.ShapeRange.Fill
                        .Visible = msoTrue
                        .ForeColor.RGB = lColor
                        .Transparency = 0
                        .Solid
                    End With
                    Selection.ShapeRange.Name = Format(dteDataDate, "yyyymmdd")
                    bSkip = False
                End If
            End If
        Next
        Application.StatusBar = Format((lDataSeriesColumnIndex - 1) / lSeriesCount, "0%")
    Next
    
    'More Lines
    With Worksheets("Main")
        With rngULCell.CurrentRegion
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
        End With
        With Range(rngDateRow.Cells(1, 1).Offset(0, -2), rngDateRow.Cells(1, 1).Offset(0, -1))
            .Borders(xlEdgeBottom).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlNone
        End With
        .Range("D5").Value = rngULCell.CurrentRegion.Width
    End With
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintArea = rngULCell.CurrentRegion.Address
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Application.PrintCommunication = True
    
    Application.ScreenUpdating = True
    Application.StatusBar = False
    
End Sub

 

[pbornemeier]