Does anyone know why my chart acts as following where the label doesn't fit to the total size?
Replaced with the hole code instead:
As below my combobox1 contains a item that will be read from a dictionary that I can access through mainGUI.getDiagramFunc. chartData contains the data that is visible on the chart. chartItem is where the names is contained.
If ComboBox1.text = "Select item" Or ComboBox1.text = "" Then Exit Sub
Dim chartIndex As Integer
ReDim chartItems(1) As String
ReDim chartdata(20) As Long
Dim myChart As Chart
Dim mySeries As Series
Dim index As Long: index = -1
Dim value As Variant
Dim temp As Variant: temp = split(mainGUI.getDiagramFunc.item(ComboBox1.text), ",")
For Each value In temp
index = index + 1
If UBound(chartItems) <= index Then ReDim Preserve chartItems(index)
chartItems(index) = mainGUI.getCalcKey(ComboBox1.text & "_*" & value)
Next value
ReDim chartdata(UBound(chartItems))
index = -1
For Each value In chartItems
index = index + 1
chartdata(index) = doCalculation(CStr(value))
Next value
On Error GoTo errorhandler
Set myChart = ActiveWorkbook.Charts(1)
Set mySeries = myChart.SeriesCollection(1)
With mySeries
.ChartType = xlColumnClustered
.XValues = temp
.Values = chartdata
End With
Dim picFileName As String
picFileName = "C:\Users\extmartefr\Desktop\data\mychart.gif"
myChart.Export Filename:=picFileName, Filtername:="GIF"
Image1.Picture = LoadPicture(picFileName)
Exit Sub
I agree with #ashleedawg that your question is not particularly clear. However, I thnk I can help.
Try adding a line of code that detects your max value and sets the x-axis maximum like this:
myChart.Axes(xlCategory).MaximumScale = (Your code to determine max x-value)
Related
I've been trying to search for days already for solutions or idea how to do this in Excel VBA, however I cannot find a similar scenario for my needs.
Here's the idea:
I have the following table as reference for the hyperlinks:
Now on a separate column, I want to create a "+" shape in each corresponding next column of the reference number and make each shape a hyperlink in reference to the first image provided. It may contain one or more shapes in one cell until all the links for that reference number has been made.
I want to do this in VBA because multiple links in single cell is not possible in Excel and hence shape/image/symbol hyperlinking is the only solution I can think of. I am clueless where to start or how to start.
I hope someone will be able to direct me as I am still learning on Excel VBA. Thank you in advance.
Set reference Microsoft Scripting Runtime
Sub SetHyperlinkOnShape()
' reference Microsoft Scripting Runtime
Dim ws As Worksheet, ws2 As Worksheet, dict As dictionary
Dim tKey(0) As Variant
Dim LRandomNumber As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
DeleteAllShapes ws2
Dim hyperLinkedShape As Shape
Dim t As Range
ColumnToPasteNumber = 2 ' on Sheet2 Column B
ColumnAlpha = "A" ' Column Latter from SHeet1 in your case H
LastRow = ws.Cells(ws.Rows.Count, ColumnAlpha).End(xlUp).Row ' get last row
Set dict = CreateObject("Scripting.Dictionary") ' put all unique value to dictionary
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 2))
For ci = 1 To LastRow ' change 1 to 2 in your case to start from second row as you have headers
strName = Rng(ci, 1)
strLink = Rng(ci, 2)
If dict.Exists(strName) Then
Dim tempArr() As Variant
tempArr() = dict(strName)
sCount = UBound(tempArr) + 1
ReDim Preserve tempArr(0 To sCount)
tempArr(sCount) = strLink
dict(strName) = tempArr
Else
tKey(0) = strLink
dict.Add strName, tKey
End If
Next ci
For Each UniqueVal In dict ' loop dictionary to paste to cells
i = i + 1
Set t = ws2.Range(ws2.Cells(i, ColumnToPasteNumber), ws2.Cells(i, ColumnToPasteNumber))
NumbersOfPluses = UBound(dict(UniqueVal)) + 1
sw = t.Width / NumbersOfPluses
ws2.Cells(i, 1).Value = UniqueVal
For y = 1 To NumbersOfPluses ' set default shape width sw
sw = t.Height 'in points
sL = t.Left + sw * (y - 1)
If y = 1 Then sL = t.Left
Set hyperLinkedShape = ws2.Shapes.AddShape(msoShapeMathPlus, sL, t.Top, sw, t.Height)
hyperLinkedShape.Placement = xlFreeFloating ' do not size and dont move
strLink = dict(UniqueVal)(y - 1)
strHint = "Click ME"
ws2.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:=strLink, SubAddress:="", ScreenTip:=strHint
Next y
If getMaxCellWidth < t.Height * NumbersOfPluses Then getMaxCellWidth = t.Height * NumbersOfPluses
Next UniqueVal
' ColumnWidth in units !!!
ws2.Columns("B:B").ColumnWidth = (((getMaxCellWidth) / 0.75 - 5) / 7) ' convert points to units
Application.ScreenUpdating = True
End Sub
Sub DeleteAllShapes(ws As Worksheet)
Dim shp As Shape
For Each shp In ws.Shapes
shp.Delete
Next shp
End Sub
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
This is the thing: I do have an energy model. The outcome is data (Watt) of the losses of energy by wall, floor, windows, ventilation, roof. The changing part in my model is the outside temperature. I did write a macro which changes this temperature from -10 to 10 Celcius. In a normal pie-chart this works nicely. So the temperature field changes and the values for wall, floor etc are updated in their respective fields.
But this is what I need: I want a graph (line or scatter) that will display: temperature (x-axis) and power (Watt, y-axis) for all 5 (wall, floor, etc) places where I lose energy.
How to do this? Can i (do i have to) collect the data and then at the end present it in a graph? Or can i tell excel to extend the graph with each new values when temperature is changed? At this point i can only display the actual data in the fields more or less.
I hope you understand my question and that someone can point me in the right direction.
This is the code I came up with so far:
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
Dim ws2 As Worksheet
Set ws2 = Sheets(2)
Dim cell As Range
' loop through temperature values given on Sheet(2)
' for now these range from -10 to 10
For Each cell In ws2.Range("A20:A40")
' update values in temperature cell
ws1.Cells.Range("D10").Value = cell.Value
' add some pause
PauseTime = 1
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Next
End Sub
And a screenshot:
The orange part in "Temperaturen" is changed by the macro. Thereby all other data will be updated and displayed in the chart. The chart will only update the y-axis values at this point. I would like to loop the temperature range (and display this as well on the x-axis) and keep the former values in the chart at their respective temperatures. (I also am not able to display the x-axis range.)
(update)
Ok, I do have a XY (scatter) graph now and I can set the x axis. This is what I do have so far:
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim tbu_min As Integer
Dim tbu_max As Integer
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
' get user values for min and max temp
tbu_min = ws1.Range("TempBuitenMin").Value
tbu_max = ws1.Range("TempBuitenMax").Value
' set chart x axis values to user input
With ws1.ChartObjects("Chart 7").Chart
With .Axes(xlCategory)
.MinimumScale = tbu_min
.MaximumScale = tbu_max
End With
End With
For temp = tbu_min To tbu_max
' update values in temperature cell
ws1.Cells.Range("D10").Value = temp
' add some pause
PauseTime = 0.5
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Next temp
End Sub
And that looks like:
Now I only need to update the data on the right temperature...
update 2 -
I updated my data for the xy scatter graph. I forgot to insert the "Series X Values". Now the right is displayed at the right temperature. I now only need to keep the output in view; at this moment it does refresh the graph each time.
Well, I did solve my problem. Not the way I wanted it, but I do not have time left to find another way. I now just collect all the data and draw a chart from within my macro. This is a prototype that does the trick.
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim tbu_min As Integer
Dim tbu_max As Integer
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
Dim dataSize As Integer
Dim dataCounter As Integer
Dim myChartObject As ChartObject
Dim addTotal As Boolean
' get user values for min and max temp
tbu_min = ws1.Range("TempBuitenMin").Value
tbu_max = ws1.Range("TempBuitenMax").Value
' how many datapoints are there
Dim xPoints() As Integer
' add surfaces
Dim muur() As Integer
Dim vloer() As Integer
Dim ramen() As Integer
Dim dak() As Integer
Dim ventilatie() As Integer
Dim totaal() As Integer
dataSize = Abs(tbu_max - tbu_min)
ReDim xPoints(dataSize)
ReDim muur(dataSize)
ReDim vloer(dataSize)
ReDim ramen(dataSize)
ReDim dak(dataSize)
ReDim ventilatie(dataSize)
ReDim totaal(dataSize)
' collect data
dataCounter = 0
For temp = tbu_min To tbu_max
' update values in temperature cell
ws1.Cells.Range("D10").Value = temp
' add x for series
xPoints(dataCounter) = temp
' add data for y series
muur(dataCounter) = ws1.Cells.Range("O24").Value
vloer(dataCounter) = ws1.Cells.Range("O47").Value
ramen(dataCounter) = ws1.Cells.Range("O61").Value
dak(dataCounter) = ws1.Cells.Range("O35").Value
ventilatie(dataCounter) = ws1.Cells.Range("O68").Value
totaal(dataCounter) = ws1.Cells.Range("O74").Value
' next
dataCounter = dataCounter + 1
Next temp
' ask to add total
If MsgBox("Wil je ook het totaal tonen in de grafiek?", vbQuestion + vbYesNo) = vbYes Then
addTotal = True
Else
addTotal = False
End If
If Not ChartExists(ws1, "buitentemperatuur") Then
' Chart does not exist, create chart
With ws1.ChartObjects.Add(Left:=200, Width:=600, Top:=200, Height:=400)
With .chart
.Parent.Name = "buitentemperatuur"
.ChartType = xlXYScatterSmooth
.Axes(xlValue).HasMajorGridlines = False
.Axes(xlCategory).Crosses = xlMinimum
.Axes(xlValue).MinimumScale = 0
.HasLegend = True
.HasTitle = True
.ChartTitle.Text = "Invloed van de buitentemperatuur"
End With
End With
End If
' Chart does exist, remove old series and update chart
ws1.ChartObjects("buitentemperatuur").Activate
For Each s In ActiveChart.SeriesCollection
s.Delete
Next s
With ws1.ChartObjects("buitentemperatuur")
With .chart
.Axes(xlValue).MaximumScaleIsAuto = True
With .SeriesCollection.NewSeries
.Name = "muur"
.XValues = xPoints
.Values = muur
End With
With .SeriesCollection.NewSeries
.Name = "vloer"
.XValues = xPoints
.Values = vloer
End With
With .SeriesCollection.NewSeries
.Name = "ramen"
.XValues = xPoints
.Values = ramen
End With
With .SeriesCollection.NewSeries
.Name = "dak"
.XValues = xPoints
.Values = dak
End With
With .SeriesCollection.NewSeries
.Name = "ventilatie"
.XValues = xPoints
.Values = ventilatie
End With
If addTotal Then
With .SeriesCollection.NewSeries
.Name = "totaal"
.XValues = xPoints
.Values = totaal
End With
End If
End With
End With
End Sub
Function ChartExists(wsTest As Worksheet, strChartName As String) As Boolean
Dim chTest As ChartObject
On Error Resume Next
Set chTest = wsTest.ChartObjects(strChartName)
On Error GoTo 0
If chTest Is Nothing Then
ChartExists = False
Else
ChartExists = True
End If
End Function
I am creating a chart, in a form, using VBA Excel 2010. I have configured excel to use Chartspace and the chart is created using dynamic data correctly, but the presentation is not what I am looking for, but can't figure how to change it. Please see the section of code:
Private Sub UserForm_Initialize()
Dim row_count As Integer
Dim n As Long
Dim chart_data As Worksheet
Set chart_data = Worksheets("Sheet3")
row_count = chart_data.UsedRange.Rows.Count
Dim varCats()
Dim varVals()
ReDim varCats(row_count)
ReDim varVals(row_count)
'Set c = ChartSpace1.Constants
Set mychart = ChartSpace1.Charts.Add
mychart.Type = xlColumnClustered '51 'chChartTypeBarClustered 'c.chChartTypeBarClustered
For n = 2 To row_count
varCats(n) = ActiveWorkbook.Sheets("Sheet3").Range("A" & n).Value
varVals(n) = ActiveWorkbook.Sheets("Sheet3").Range("T" & n).Value
Next n
mychart.SeriesCollection.Add
With mychart.SeriesCollection(0)
.SetData chDimSeriesNames, chDataLiteral, "QAR Score"
.SetData chDimCategories, chDataLiteral, varCats
.SetData chDimValues, chDataLiteral, varVals
End With
End Sub
The bar chart is showing the bars horizontally and not vertically. So where I thought my variable "varCats" would go to the X-Axis is not but rather the Y-axis.
I know this is going to be a simple response from the community, but I have yet to find it through my searching.
Thanks,
C
Image from the answer provide:
Desired Results:
Revised to work with ChartSpace objects in UserForm
Private Sub UserForm_Initialize()
Dim row_count As Integer
Dim n As Long
Dim chart_data As Worksheet
Dim srs As ChSeries
Dim myChart As ChChart
Set chart_data = Worksheets("Sheet3")
row_count = chart_data.UsedRange.Rows.Count
ReDim varCats(1 To row_count)
ReDim varVals(1 To row_count)
varCats = Application.Transpose(chart_data.Range("A2:A" & row_count).Value)
varVals = Application.Transpose(chart_data.Range("T2:B" & row_count).Value)
'Set c = ChartSpace1.Constants
Set myChart = ChartSpace1.Charts.Add
myChart.Type = chChartTypeColumnClustered
Set srs = myChart.SeriesCollection.Add
With srs
.SetData chDimSeriesNames, chDataLiteral, "QAR Score"
.SetData chDimCategories, chDataLiteral, varCats
.SetData chDimValues, chDataLiteral, varVals
End With
End Sub
I am trying to get Excel data, which was mapped using a grid/matrix mapping into a de-normalized for so that i can enter the data into a database.
How do you copy data in a grid from one excel sheet to the other as follow illustrated below.
I was trying something like this... but as you can see, i am far off!
Sub NormaliseList(mySelection As Range)
Dim cell As Range
Dim i As Long
i = 1
For Each cell In mySelection
If cell <> "" Then
Sheets(2).Range("A" & i).Value = cell(cell.Row, 1).Value
Sheets(2).Range("B" & i).Value = cell.Value
Sheets(2).Range("C" & i).Value = cell(1, cell.Column).Value
i = i + 1
Next cell
End Sub
For Reference. I Updated my code..
Simply add the code, assign macro shortcut to the function
Select the range that contains the intersection data (not the row and column data)
Run macro (Beware, sheet 2 will have data added in normalised form)
If there are multiple headings that are needed i figured i would consolidate into one column then perform a "text to columns" after processing.
Sub NormaliseList()
' to run - assign macro shortcut to sub - Select Intersection data (not row and column headings and run)
Dim Rowname, ColumnName, IntValue As String
Dim x, cntr As Integer
Dim test As Boolean
cntr = 0
For x = 1 To Selection.Count
If Selection(x).Value <> "" Then
cntr = cntr + 1
Rowname = ActiveSheet.Cells(Selection.Cells(x).Row, Selection.Column - 1)
ColumnName = ActiveSheet.Cells(Selection.Row - 1, Selection.Cells(x).Column)
IntValue = Selection(x).Value
test = addrecord(Rowname, ColumnName, IntValue, cntr)
End If
Next x
End Sub
Function addrecord(vA, vB, vC As String, rec As Integer) As Boolean
'Make sure that you have a worksheet called "Sheet2"
Sheets("Sheet2").Cells(rec, 1) = vA
Sheets("Sheet2").Cells(rec, 2) = vB
Sheets("Sheet2").Cells(rec, 3) = vC
End Function
I've got two posts, with usable code and downloadable workbook, on doing this in Excel/VBA on my blog:
http://yoursumbuddy.com/data-normalizer
http://yoursumbuddy.com/data-normalizer-the-sql/
Here's the code:
'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.
Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)
Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With
'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i
'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i
'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With
'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If
With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList
'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete
'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub
You’d call it like this:
Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 1, "Name", "Count", False
End Sub