Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Closed Thread
 
Thread Tools Display Modes
  #1  
Old 08-26-2020, 09:47 PM
leeqiang leeqiang is offline how to draw the histogram? Windows 10 how to draw the histogram? Office 2019
Novice
how to draw the histogram?
 
Join Date: Aug 2020
Posts: 16
leeqiang is on a distinguished road
Default how to draw the histogram?

In the worksheet, column A is the data to be processed, column c is the separation point, column d is the data interval, column e is the data frequency, column f is the data frequency, and column g is the data frequency divided by the group distance,This code adapts to each column of data containing the header.


The header name of the worksheet c list is the separation point, the name of the d list header is the interval, the name of the e list header is the frequency, the name of the f list header is the frequency, and the name of the g list header is the frequency divided by the group distance.



The data source is in column A, but because of changes in C's data, i.e. the starting data value and step used to draw histograms, the grouping changes, resulting in changes in the data in column d, which is next to the other columns, and the data used in the drawing is only d columns and g columns. So the code needs to be adaptive, and the data area referenced by the drawing automatically matches as the d column changes, but in the above instance, when you change the data source area in the drawing program, the resulting picture is a single-colored histogram, and the spacing between each column is not close together. If you want to implement automatic reference data areas, the resulting picture is the first to appear in the specification effect, how to rewrite the code? Thank you!



the excel file:
cplans.xlsm


the code is as follows:
the first question is:How to optimize this running code.

Option Explicit
Sub maxmin()
Dim xU As Range, vMin, vMax, MinADS$, MaxADS$
Dim p, q, groupsp, drow
Set xU = ActiveSheet.Columns("a")
vMin = Application.Min(xU)
vMax = Application.Max(xU)
MinADS = xU.Find(vMin, Lookat:=xlWhole).Address(0, 0)
'MaxADS = xU.Find(vMax, Lookat:=xlWhole).Address(0, 0)
'MsgBox MinADS & " " & CDec(vMin) & vbCrLf & MaxADS & " " & CDec(vMax)
[b1] = "Min"
[b2] = vMin
[b3] = "Max"
[b4] = vMax
[b5] = "gap"
[b6] = vMax - vMin
[b7] = "gropspace"
[b9] = "gropno"
p = ActiveSheet.Cells.Rows.Count
q = ActiveSheet.Cells(p, 3).End(xlUp).Row
If q >= 2 Then
groupsp = Cells(q, 3) - Cells(q - 1, 3)
[b8] = groupsp
Else


groupsp = [b8].Value
End If
'Range("c3:C" & q).Clear
If q <= 1 And [b8].Value = "" Then Exit Sub
If [c1].Value = "" And [b8].Value <> "" Then Exit Sub
For drow = q + 1 To ActiveSheet.Cells.Rows.Count
Cells(drow, 3) = Cells(drow - 1, 3) + groupsp
If Cells(drow, 3) = vMax Then Exit For
If Cells(drow, 3) > vMax Then Exit For
Next drow

'MsgBox groupsp
[b10] = ActiveSheet.Cells(p, 3).End(xlUp).Row - 1
End Sub


Sub histogram()
Dim p, q, t, i, n, d, j, m, r, s, x, l
Dim arr, brr, title
Columns("D:G").ClearContents
'Locate the number of rows in which the last row of data
'in the reference column is located.
p = ActiveSheet.Cells.Rows.Count
q = ActiveSheet.Cells(p, 3).End(xlUp).Row
'Set the maximum area where the data is located to an array.
'A is listed as the column in which the data source is located which name is arr.
'brr where the data is located to an array.
arr = Range("A1").CurrentRegion
brr = ActiveSheet.Range("c1:g" & q)
Range("d1:g" & UBound(brr)).ClearContents
'the no.of the data and the space
n = UBound(arr) - LBound(arr) + 1
d = brr(3, 1) - brr(2, 1)
'title is the header of the colum
title = Array("Group", "Frequency", "Frequency", "Frequency/group space")
'write the header of the data area
i = 0
For t = LBound(brr, 2) + 1 To UBound(brr, 2)
brr(1, t) = title(i)
i = i + 1
Next t
'Process the data in column c of the worksheet
'and generate interval data in column d
'Build data grouping intervals.
brr(2, 2) = "[" & 0 & "," & brr(1, 1) & ")"
For i = LBound(brr) + 1 To UBound(brr)
If IsNumeric(brr(i - 1, 1)) Then brr(i, 2) = "[" & brr(i - 1, 1) & "," & brr(i, 1) & ")"
Next i
'process the data in column a and produce the frequency
For j = 2 To UBound(brr)
brr(j, 3) = 0
For m = 1 To UBound(arr)
'If arr(m, 1) >= brr(j, 1) And arr(m, 1) < brr(j - 1, 1) Then brr(j, 3) = 0
If arr(m, 1) < brr(j, 1) And arr(m, 1) >= brr(j - 1, 1) Then brr(j, 3) = brr(j, 3) + 1
If Not IsNumeric(brr(j - 1, 1)) And arr(m, 1) < brr(j, 1) And arr(m, 1) >= 0 Then brr(j, 3) = brr(j, 3) + 1
Next
brr(j, 4) = brr(j, 3) / n
brr(j, 5) = brr(j, 4) / d
Next
ActiveSheet.Range("c1:g" & q) = brr
'sum of the data
x = UBound(brr) + 1
Cells(x, 4) = "Total"
'add the number
For r = LBound(brr, 2) + 2 To UBound(brr, 2)
For l = LBound(brr) + 1 To UBound(brr)
Cells(x, r + 2) = Cells(x, r + 2) + brr(l, r)
Next l
Next r
End Sub








in this case,I want to use the result of macro range(d1:d6) and range(g1:g6) to draw the histogram,so I copy the two columns data to columns k and l from cells k1.because macro quote the range("k1:l6")can produce the good look histogram.
the result is like this:

20200827120613.png

use the code as follows:
Sub AddChart1()
Dim chtChart As Chart
Set chtChart = Charts.Add
With chtChart
.SetSourceData Source:=Sheet1.Range("K1:L6"), PlotBy:=xlRows
.ChartType = xlColumnClustered
.HasDataTable = True
.ApplyDataLabels
.HasTitle = True
.ChartTitle.Text = "histogram"
.HasLegend = True
.Name = "histogram"
End With
Set chtChart = Nothing
End Sub








but when i use the code as follws,some questions happened:
Sub copyd()
Dim p, q
Columns("k:l").ClearContents
p = ActiveSheet.Cells.Rows.Count
q = ActiveSheet.Cells(p, 4).End(xlUp).Row
Range("D1" & q - 1).Select
Selection.Copy
Range("K1").Select
ActiveSheet.Paste
Range("G1:G" & q - 1).Select
Application.CutCopyMode = False
Selection.Copy
Range("L1").Select
ActiveSheet.Paste

Dim chtChart As Chart
Set chtChart = Charts.Add
With chtChart
.SetSourceData Source:=ActiveSheet.[k1].CurrentRegion, PlotBy:=xlRows
.ChartType = xlColumnClustered
.HasDataTable = True
.ApplyDataLabels
.HasTitle = True
.ChartTitle.Text = "histogram"
.HasLegend = False
.Name = "histogram"
End With
Set chtChart = Nothing
End Sub


application alert:

20200827120955.png





histogram each colunm have space between each other,and the column have the some color,not the different colours:
20200827121045.png
  #2  
Old 08-27-2020, 05:19 PM
macropod's Avatar
macropod macropod is offline how to draw the histogram? Windows 7 64bit how to draw the histogram? Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 20,464
macropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant futuremacropod has a brilliant future
Default

This thread is a duplicate of:
https://www.msofficeforums.com/excel...tribution.html
Kindly don't ask questions about the same topic in multiple threads.

Thread closed. You may continue the discussion in your other thread.
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
Closed Thread

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Problems with vba frequency distribution histogram leeqiang Excel Programming 19 09-01-2020 08:54 PM
how to draw the histogram? How to draw a fill in the blanks ? kingston123 Word 2 09-21-2018 05:49 AM
how to draw this graph? blackspider Excel 0 01-27-2017 01:36 AM
how to draw the histogram? How to draw this chart Misty PowerPoint 7 05-16-2015 06:30 AM
Communicator - Draw?? tecra134 Misc 0 09-30-2011 10:59 AM

Other Forums: Access Forums - Senior Forums

All times are GMT -7. The time now is 01:19 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2020, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2020 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft