Chart and VBA.

pedie

pedie

Well-known Member
Joined
Apr 28, 2010
Messages
3,875
Hi Can someone please write a vba or show me example on how this can be achieved.

I want pre-created chart copied and pasted into email body [as picture] and then mail it to single recepient.

Thanks for helping.
:)
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
Here is what I use for messing around

Just run the macro - the rest is automatic - I use arrays for mine - but you can use ranges instead - that would be for properties .Xvalues & .Values

Enjoy

Module1
Code: 
Option Explicit

Public Sub AddHistochart()
    Dim NumCharts As Long
    Dim YPlotValues() As Variant
    Dim XPlotValues() As Single
    Dim i As Long, ii As Long
    Dim frequency() As Variant
    Dim binlabel() As Variant
    Dim binsize As Variant
    Dim minimumX As Single
    Dim maximumX As Single
    Dim NumBins As Long
    Dim Along As Long, AAlong As Long
    Dim NumParameters As Long
    Dim HighFrequency As Long
    Dim Asingle As Single
    Dim Avar As Variant
    Dim MeanVal() As Single
    Dim CounterVal() As Long
    
    Application.StatusBar = "Making Histogram"
    NumBins = 18
    NumParameters = 1
    
   
   
    ReDim frequency(1 To NumBins)
    ReDim binlabel(1 To NumBins)
    
    Call GetArrayValue(YPlotValues, XPlotValues, minimumX, maximumX)
    binsize = (maximumX - minimumX) / NumBins
    For i = 1 To NumBins
        binlabel(i) = Format(minimumX + 0.5 * binsize + (i - 1) * binsize, "####0.00")
    Next i
    HighFrequency = 0
    For i = 1 To NumBins - 1
        For ii = 0 To UBound(YPlotValues)
            If YPlotValues(ii) >= binlabel(i) - 0.5 * binsize And YPlotValues(ii) < binlabel(i + 1) - 0.5 * binsize Then
                frequency(i) = frequency(i) + 1
                If frequency(i) > HighFrequency Then HighFrequency = frequency(i)
            End If
        Next ii
    Next i
    '******* last bin
    For i = 0 To UBound(YPlotValues)
        If YPlotValues(i) >= binlabel(NumBins) - 0.5 * binsize And YPlotValues(i) < maximumX Then
            frequency(NumBins) = frequency(NumBins) + 1
            If frequency(NumBins) > HighFrequency Then HighFrequency = frequency(i)
        End If
    Next i
    NumCharts = ActiveSheet.ChartObjects.Count
    If NumCharts > 0 Then
        For i = NumCharts To 1 Step -1
            ActiveSheet.ChartObjects(i).Delete
        Next i
    End If
    Along = 1
  
    ReDim MeanVal(1 To HighFrequency)
    ReDim CounterVal(1 To HighFrequency)
    Along = UBound(YPlotValues)
    Asingle = 0
    AAlong = 0
    For i = 0 To UBound(YPlotValues)
        Asingle = Asingle + YPlotValues(i)
        AAlong = AAlong + 1
    Next i
    Asingle = Asingle / AAlong 'Mean value
   
    For i = 1 To HighFrequency
        CounterVal(i) = i - 1
        MeanVal(i) = Asingle
        'MeanVal(i) = 10
    Next i
   
  
   GoTo StartMakingCharts
    ActiveSheet.ChartObjects.Add Left:=50, Top:=50, Width:=600, Height:=300
    NumCharts = ActiveSheet.ChartObjects.Count
    If NumCharts > 1 Then
        ActiveSheet.ChartObjects(NumCharts).Left = ActiveSheet.ChartObjects(NumCharts - 1).Left
        ActiveSheet.ChartObjects(NumCharts).Top = ActiveSheet.ChartObjects(NumCharts - 1).Top + ActiveSheet.ChartObjects(NumCharts - 1).Height + 20
        ActiveSheet.ChartObjects(NumCharts).Height = ActiveSheet.ChartObjects(NumCharts - 1).Height
        ActiveSheet.ChartObjects(NumCharts).Width = ActiveSheet.ChartObjects(NumCharts - 1).Width
    End If
    NumCharts = ActiveSheet.ChartObjects.Count
    ActiveSheet.ChartObjects(NumCharts).Activate
    Dim Achart As ChartObject
    Set Achart = ActiveSheet.ChartObjects(NumCharts)
    
    With Achart.Chart     'Set chart properties
       If NumCharts = 1 Then
                .ChartType = xlColumnClustered
            Else
                .ChartType = xlXYScatterSmoothNoMarkers 'works
                '.ChartType = xlXYScatter 'True XY scatter
                '.ChartType = xlLineMarkers 'in current SPC chart
                '.ChartType = xlLine
               
                '.Axes(xlCategory, xlPrimary).HasTitle = True
                '.Axes(xlValue, xlPrimary).HasTitle = False
               
        End If
        .SeriesCollection.NewSeries
        .HasLegend = False
        .Axes(xlCategory).MajorTickMark = xlTickMarkOutside
        .Axes(xlValue).MajorTickMark = xlTickMarkOutside 'xlTickMarkNone
        .Axes(xlValue).MinimumScale = 0
        .Axes(xlValue).MaximumScale = HighFrequency + 1
        
        
        Along = UBound(frequency)
        AAlong = UBound(frequency)
        
       
        
        .SeriesCollection(NumParameters).Values = Array(frequency) ' creates bars
        .SeriesCollection(NumParameters).XValues = Array(binlabel)
       
        'If .ChartType = xlLine Or .ChartType = xlLineMarkers Then .SeriesCollection(NumParameters).Smooth = True
        
        
        'With .Shapes.AddLine(200, 0, 200, 250) '(BeginX, BeginY, EndX, EndY)
        '    .Line.ForeColor.SchemeColor = 10
        '    .Line.Visible = msoTrue
        '    .Line.Weight = 1.5
        '    .Line.Visible = msoTrue
        '    .Line.Style = msoLineSingle
        '    .Line.DashStyle = msoLineSquareDot
        'End With
 
      
        'Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=4, Degree:=0.231372549019608
        
        .Axes(xlCategory).HasTitle = True
        .Axes(xlCategory).AxisTitle.Characters.Text = "Predictions"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Characters.Text = "Frequency"
        'If .ChartType = xlLine Or .ChartType = xlLineMarkers Or .ChartType = xlXYScatterSmoothNoMarkers Then
           
        
            
        If NumCharts = 2 Then
'With myChart.Axes(xlValue)
'    If .AxisGroup = xlSecondary Then .Delete
'End With
            
            '.HasAxis(xlCategory, xlSecondary) = True
            
            '.Axes(xlValue).AxisGroup = xlSecondary
            '.Axes(xlValue).AxisGroup = 2
            
            .SeriesCollection.NewSeries
            .SeriesCollection(NumParameters + 1).Values = Array(CounterVal)
            .SeriesCollection(NumParameters + 1).XValues = Array(MeanVal) ' creates bars
            .SeriesCollection(NumParameters + 1).Smooth = True
            
            '.HasAxis(xlCategory, xlSecondary) = True
            '.HasAxis(xlValue, xlSecondary) = True
            
            .SeriesCollection.NewSeries 'Fonny series
            .SeriesCollection(NumParameters + 2).Values = Array(CounterVal)
            .SeriesCollection(NumParameters + 2).XValues = Array(MeanVal) ' creates bars
            .SeriesCollection(NumParameters + 2).Smooth = True
            '.HasAxis(xlValue, xlSecondary) = True
            .HasAxis(xlValue, xlSecondary) = True
           
            .SeriesCollection(NumParameters + 2).AxisGroup = 2
            
 
          
            
            .HasAxis(xlCategory, xlSecondary) = True
            .Axes(xlCategory, xlSecondary).HasTitle = True
            .Axes(xlCategory, xlSecondary).AxisTitle.Caption = "This is it" '.Characters.Text = "2nd axis"
            
            With .Axes(xlValue, xlSecondary)
                .MinimumScale = 0
                .MaximumScale = 25
                .MinorUnitIsAuto = True
                .MajorUnit = 5
                .Crosses = xlCustom
                .CrossesAt = 0
                .ReversePlotOrder = False
                .ScaleType = xlLinear
                .DisplayUnit = xlNone
            End With
            'Selection.TickLabels.NumberFormat = "0"
            ActiveChart.Axes(xlValue).Select
        End If
       
        
    End With
    Set Achart = Nothing
    
    If NumCharts = 1 Then GoTo StartMakingCharts
    
    Application.StatusBar = "Completed ---- Making Histogram/Curve Histogram - Start new Task"
End Sub
 
 
Private Sub GetArrayValue(YPlotValues, XPlotValues, minimumX, maximumX)
Dim NumObvs As Long
NumObvs = 178
minimumX = 9.1
maximumX = 14
ReDim YPlotValues(NumObvs)
ReDim XPlotValues(40)
YPlotValues(0) = 10.406: XPlotValues(0) = 10.6
YPlotValues(1) = 10.496: XPlotValues(1) = 10.4
YPlotValues(2) = 10.3: XPlotValues(2) = 10.2
YPlotValues(3) = 10.469: XPlotValues(3) = 10.6
YPlotValues(4) = 10.381: XPlotValues(4) = 10.4
YPlotValues(5) = 10.148: XPlotValues(5) = 10.1
YPlotValues(6) = 10.306: XPlotValues(6) = 10.6
YPlotValues(7) = 10.457: XPlotValues(7) = 10.5
YPlotValues(8) = 9.893: XPlotValues(8) = 9.9
YPlotValues(9) = 9.881: XPlotValues(9) = 9.7
YPlotValues(10) = 9.44: XPlotValues(10) = 10
YPlotValues(11) = 9.276: XPlotValues(11) = 9.3
YPlotValues(12) = 9.162: XPlotValues(12) = 9.2
YPlotValues(13) = 9.721: XPlotValues(13) = 9.6
YPlotValues(14) = 9.61: XPlotValues(14) = 9.6
YPlotValues(15) = 9.804: XPlotValues(15) = 9.7
YPlotValues(16) = 9.794: XPlotValues(16) = 9.93
YPlotValues(17) = 10.27: XPlotValues(17) = 10.21
YPlotValues(18) = 10.416: XPlotValues(18) = 10.38
YPlotValues(19) = 10.571: XPlotValues(19) = 10.62
YPlotValues(20) = 10.793: XPlotValues(20) = 11
YPlotValues(21) = 11.061: XPlotValues(21) = 11
YPlotValues(22) = 11.28: XPlotValues(22) = 11.25
YPlotValues(23) = 11.472: XPlotValues(23) = 11.41
YPlotValues(24) = 11.527: XPlotValues(24) = 11.58
YPlotValues(25) = 11.809: XPlotValues(25) = 11.82
YPlotValues(26) = 11.962: XPlotValues(26) = 11.9
YPlotValues(27) = 12.141: XPlotValues(27) = 12.11
YPlotValues(28) = 12.328: XPlotValues(28) = 12.28
YPlotValues(29) = 12.49: XPlotValues(29) = 12.45
YPlotValues(30) = 12.677: XPlotValues(30) = 12.58
YPlotValues(31) = 12.871: XPlotValues(31) = 12.92
YPlotValues(32) = 12.951: XPlotValues(32) = 12.97
YPlotValues(33) = 13.15: XPlotValues(33) = 13.11
YPlotValues(34) = 13.305: XPlotValues(34) = 13.28
YPlotValues(35) = 13.272: XPlotValues(35) = 13.26
YPlotValues(36) = 13.168: XPlotValues(36) = 13.14
YPlotValues(37) = 13.457: XPlotValues(37) = 13.44
YPlotValues(38) = 13.411: XPlotValues(38) = 1344
YPlotValues(39) = 13.613: XPlotValues(39) = 13.62
YPlotValues(40) = 13.651
YPlotValues(41) = 13.91
YPlotValues(42) = 11.053
YPlotValues(43) = 11.176
YPlotValues(44) = 11.153
YPlotValues(45) = 11.902
YPlotValues(46) = 11.111
YPlotValues(47) = 11.316
YPlotValues(48) = 11.839
YPlotValues(49) = 11.633
YPlotValues(50) = 11.752
YPlotValues(51) = 11.709
YPlotValues(52) = 11.868
YPlotValues(53) = 12.061
YPlotValues(54) = 12.223
YPlotValues(55) = 12.164
YPlotValues(56) = 12.308
YPlotValues(57) = 12.541
YPlotValues(58) = 12.389
YPlotValues(59) = 12.697
YPlotValues(60) = 12.722
YPlotValues(61) = 12.458
YPlotValues(62) = 12.888
YPlotValues(63) = 12.999
YPlotValues(64) = 12.072
YPlotValues(65) = 12.953
YPlotValues(66) = 11.03
YPlotValues(67) = 11.192
YPlotValues(68) = 11.086
YPlotValues(69) = 11.197
YPlotValues(70) = 11.236
YPlotValues(71) = 11.324
YPlotValues(72) = 11.696
YPlotValues(73) = 11.732
YPlotValues(74) = 11.943
YPlotValues(75) = 12.113
YPlotValues(76) = 12.17
YPlotValues(77) = 12.475
YPlotValues(78) = 12.349
YPlotValues(79) = 13.006
YPlotValues(80) = 12.688
YPlotValues(81) = 12.655
YPlotValues(82) = 12.869
YPlotValues(83) = 13.098
YPlotValues(84) = 13.127
YPlotValues(85) = 13.146
YPlotValues(86) = 13.493
YPlotValues(87) = 13.746
YPlotValues(88) = 13.729
YPlotValues(89) = 13.833
YPlotValues(90) = 14.026
YPlotValues(91) = 13.958
YPlotValues(92) = 11.208
YPlotValues(93) = 11.098
YPlotValues(94) = 11.4
YPlotValues(95) = 11.221
YPlotValues(96) = 11.22
YPlotValues(97) = 11.191
YPlotValues(98) = 10.946
YPlotValues(99) = 11.353
YPlotValues(100) = 11.274
YPlotValues(101) = 11.361
YPlotValues(102) = 11.173
YPlotValues(103) = 11.034
YPlotValues(104) = 10.986
YPlotValues(105) = 11.025
YPlotValues(106) = 10.88
YPlotValues(107) = 10.862
YPlotValues(108) = 10.852
YPlotValues(109) = 11.185
YPlotValues(110) = 10.71
YPlotValues(111) = 10.83
YPlotValues(112) = 10.961
YPlotValues(113) = 10.71
YPlotValues(114) = 10.895
YPlotValues(115) = 10.66
YPlotValues(116) = 10.712
YPlotValues(117) = 10.86
YPlotValues(118) = 10.777
YPlotValues(119) = 10.779
YPlotValues(120) = 10.596
YPlotValues(121) = 10.754
YPlotValues(122) = 10.488
YPlotValues(123) = 10.829
YPlotValues(124) = 10.667
YPlotValues(125) = 10.527
YPlotValues(126) = 10.378
YPlotValues(127) = 10.188
YPlotValues(128) = 10.566
YPlotValues(129) = 10.468
YPlotValues(130) = 10.488
YPlotValues(131) = 10.389
YPlotValues(132) = 10.188
YPlotValues(133) = 10.29
YPlotValues(134) = 10.313
YPlotValues(135) = 10.289
YPlotValues(136) = 10.214
YPlotValues(137) = 10.194
YPlotValues(138) = 10.126
YPlotValues(139) = 10.125
YPlotValues(140) = 10.071
YPlotValues(141) = 10.248
YPlotValues(142) = 10.157
YPlotValues(143) = 10.242
YPlotValues(144) = 10.128
YPlotValues(145) = 10.028
YPlotValues(146) = 10.304
YPlotValues(147) = 10.092
YPlotValues(148) = 10.038
YPlotValues(149) = 9.995
YPlotValues(150) = 10.132
YPlotValues(151) = 10.131
YPlotValues(152) = 9.857
YPlotValues(153) = 10.22
YPlotValues(154) = 9.977
YPlotValues(155) = 10.135
YPlotValues(156) = 10.181
YPlotValues(157) = 10.042
YPlotValues(158) = 9.988
YPlotValues(159) = 10.151
YPlotValues(160) = 10.108
YPlotValues(161) = 10.16
YPlotValues(162) = 10.088
YPlotValues(163) = 10.224
YPlotValues(164) = 10.078
YPlotValues(165) = 10.05
YPlotValues(166) = 9.901
YPlotValues(167) = 9.915
YPlotValues(168) = 9.988
YPlotValues(169) = 9.999
YPlotValues(170) = 10.005
YPlotValues(171) = 9.962
YPlotValues(172) = 9.971
YPlotValues(173) = 10.075
YPlotValues(174) = 9.989
YPlotValues(175) = 10.015
YPlotValues(176) = 10.086
YPlotValues(177) = 10.172
 
End Sub
 
Upvote 0
ops deleted one to many lines

StartMakingCharts: 'I deleted this line by mistake - I removed some code
ActiveSheet.ChartObjects.Add Left:=50, Top:=50, Width:=600, Height:=300
 
Upvote 0
Brian, thanks that was exactly what I was looking for...
Rasm, still trying here, seems to error....
 
Upvote 0
I read other link - guess I misunderstood - that code just makes a chart - but it should work. But it is not what you are asking for - I think
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question Question
How set range for chart in powerpoint created from vba
Replies
0
Views
117
Legacy 519704
L
M
  • Question Question
Grouping rows of data for a chart
Replies
2
Views
80
marcidee
M
M
  • Question Question
Add text before pasting pic in outlook
Replies
2
Views
88
DanteAmor
DanteAmor
G
  • Locked
  • Question Question
Printing excel chart in high quality
Replies
1
Views
115
Peter_SSs
Peter_SSs
N
  • Solved
Help with creating a macro
Replies
2
Views
128
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,544
Messages
6,179,430
Members
452,915
Latest member
hannnahheileen

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top