Step curves

Hi,

I need a VBA-program for drawing step curves, i.e. the curve is horizontel until the y-value changes. The curves are thus discontinuous. A good example could be price curves.

An example is enclosed where x represents quaters and then there are data series, in this case Y1, Y2 and Y3. In this example there should thus be three curves.

Could some one help me?

Kind regards,

Jan

See next code
Of course make a copy of the sheet

Sub PrepareData()
Dim WkTbl1(), WkTbl2()
Dim WkRg  As Range
Dim I As Long, J As Long, K As Long

    WkTbl1 = Range("A1").CurrentRegion.Offset(1, 0)
    ReDim WkTbl2(1 To 2 * UBound(WkTbl1, 1), 1 To 4)
    K = 1: I = 1
    Do
        For J = 2 To 4
            WkTbl2(K, J) = WkTbl1(I, J)
            WkTbl2(K + 1, J) = WkTbl1(I, J)
        Next J
        WkTbl2(K, 1) = WkTbl1(I, 1)
        WkTbl2(K + 1, 1) = WkTbl1(I + 1, 1)
        I = I + 1
        K = K + 2
    Loop While (I <= UBound(WkTbl1, 1) - 1)
    For J = 2 To 4
        WkTbl2(K - 1, J) = Empty
    Next J
    Range("A2").Resize(UBound(WkTbl2, 1), 4) = WkTbl2
End Sub

Please see the attachment, The closest that I could get was to use a histogram with overlapping bars and not fill.

Hi!

Thank you very much for your macro.

I suppose it is designed for 3 sets of Y columns.

If you would like to change it to any number of columns , i.e. 2,4,5 etc. and not only 3, how would the macro be changed?

Kind regards,

Jan

Here we are

Sub PrepareData1()
Dim WkTbl1(), WkTbl2()
Dim WkRg  As Range
Dim I As Long, J As Long, K As Long

    Application.ScreenUpdating = False
    WkTbl1 = Range("A1").CurrentRegion.Offset(1, 0)
    ReDim WkTbl2(1 To 2 * UBound(WkTbl1, 1), 1 To UBound(WkTbl1, 2))
    K = 1: I = 1
    Do
        For J = 2 To UBound(WkTbl1, 2)
            WkTbl2(K, J) = WkTbl1(I, J)
            WkTbl2(K + 1, J) = WkTbl1(I, J)
        Next J
        WkTbl2(K, 1) = WkTbl1(I, 1)
        WkTbl2(K + 1, 1) = WkTbl1(I + 1, 1)
        I = I + 1
        K = K + 2
    Loop While (I <= UBound(WkTbl1, 1) - 1)
    For J = 2 To UBound(WkTbl1, 2)
        WkTbl2(K - 1, J) = Empty
    Next J
    Range("A2").Resize(UBound(WkTbl2, 1), UBound(WkTbl1, 2)) = WkTbl2
    Application.ScreenUpdating = True
End Sub

Hi!

Thanks for all help with the macro!

It functions now properly!

Kind regards,

Jan

My pleasure
PCI