I have a table with Max Min for each line graph. I want to build a macro that will update each line graph (40 in total) off of a table. Please Advise.
Here is what I have so far. I'm sure its poorly written as I'm starting to learn how to write VBA.
Sub Update_Slope()
With Chart(2).Axes(xlValue, xlPrimary)
.MaximumScale = ActiveSheet.Range("F58").Value
' Constant value
.MinimumScale = ActiveSheet.Range("F68").Value
' Constant Value
With Chart(4).Axes(xlValue, xlPrimary)
.MaximumScale = ActiveSheet.Range("F59").Value
' Constant value
.MinimumScale = ActiveSheet.Range("F69").Value
' Constant Value
End With
End Sub
UNTESTED
Sub Update_Slope()
ActiveSheet.ChartObjects("Chart(2)").Activate
ActiveChart.Axes(xlCategory).MinimumScale = Range("F68").Value
ActiveChart.Axes(xlCategory).MaximumScale = Range("F58").Value
ActiveSheet.ChartObjects("Chart(4)").Activate
ActiveChart.Axes(xlCategory).MinimumScale = Range("F69").Value
ActiveChart.Axes(xlCategory).MaximumScale = Range("F59").Value
End Sub
Sub Update_All_Slopes()
Dim co, sht as WorkSheet
Set sht = Activesheet
Set co = sht.ChartObjects
'ideally you're looping through your table range to do this, instead
' of hard-coding each line. Need more info on how your sheet is set up
' and how to identify which chart should be updated...
FixYAxis co("Chart2").Chart,sht.Range("F68").Value, sht.Range("F58").Value
FixYAxis co("Chart4").Chart,sht.Range("F69").Value, sht.Range("F59").Value
'...etc
End Sub
Sub FixYAxis(cht as Chart, minVal,maxVal)
With cht.Axes(xlValue, xlPrimary)
.MaximumScale = maxVal
.MinimumScale = minVal
End With
End Sub
Related
I can't seem to get this code to work. I am getting a run-time error 13 'type mismatch'. As the code suggests I would like to set X and Y axis values from the ranges in Z6:Z9.
Sub Axis()
Dim Cht As ChartObject
Set Cht = Worksheets("Data Input & Summary").ChartObjects("Chart 2").Chart
With Cht.Axes(xlCategory)
.MaximumScale = .Range("Z7").Value
.MinimumScale = .Range("Z6").Value
End With
With Cht.Axes(xlValue)
.MaximumScale = .Range("Z9").Value
.MinimumScale = .Range("Z8").Value
End With
End Sub
In general, you have about 3 errors in your code.
This is how it should look like:
Sub AxisSomething()
Dim Cht As ChartObject
Set Cht = Worksheets(1).ChartObjects(1)
With Cht.Chart.Axes(xlCategory)
.MaximumScale = Worksheets(1).Range("Z7").Value
.MinimumScale = Worksheets(1).Range("Z6").Value
End With
With Cht.Chart.Axes(xlValue)
.MaximumScale = Worksheets(1).Range("Z9").Value
.MinimumScale = Worksheets(1).Range("Z8").Value
End With
End Sub
You declare Cht as a ChartObject, but you set it to chart.
If you declare it as a ChartObject, to get the .Axes you should refer to the .Chart of the Chart Object.
Whenever you use ., it refers to the with above. And the .Range should not refer to the Chart.Axes(xlCategory)
Last but not least - when you upload code to StackOverflow, it is a good idea to make it "reproductable". Thus, instad of Worksheets("Data Input & Summary") write Worksheets(1). And then fix the name yourself.
Hey I'm new to forums and this is my first post. I am new to vba in excel, but have written thinkscript in ThinkorSwim.
If anyone is familiar with a range stock chart, thats what Im going after.
I found code for a line chart, and am using it, but it is based on where price is at any given time. I want to modify this line chart to only plot values when they are above or below a range so that it resembles a candlestick chart with no wicks. Once data enters that range, I only want it to update whenever a new high or low is made in that range. The ranges need to be preset (ex. 50 ticks) Once the range is exceeded, I want the data plotted in the next range up, and repeat the process. Time and dates should be ignored, and only plot based on price action.
Does anyone have any ideas?
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Sheet1"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.Name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").Value = "Time"
.Range("B1").Value = "Value"
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:B1"), _
xllistobjecthasheaders:=xlYes)
lstObject.Name = sTableName
.Range("A2").NumberFormat = "h:mm:ss AM/PM (mmm-d)"
.Columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Range
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).Row
End If
If lRow = 0 Then
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End If
If lRow > 2 Then
If .Range("B" & lRow - 1).Value = Worksheets(sSourceWSName).Range("C10").Value Then
'Data is a match, so do nothing
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
Take your sheet of data and filter... example would be:
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlAscending, header:=xlYes
Sort info: https://msdn.microsoft.com/en-us/library/office/ff840646.aspx
You then can define to select your desired range. Assuming column A is x-axis and B is y-axis (where your parameters for modifying need to be assessed):
Dim High1 as integer
Dim Low1 as integer
High1 = Match(Max(B:B),B:B) 'This isn't tested, just an idea
Low1 = Match(Max(B:B)+50,B:B) 'Again, not tested
and using those defined parameters:
.Range(Cells(High1,1),Cells(Low1,2).Select
This should give an idea for High1/Low1, where you can work through how you want to define the row that the max value occurs.
You then CreateObject for the Chart you want, having selected the data range you are going to use.
By the following code Max. and Min. scale for primary horizontal X-axis of a chart in vba is being set;
Sub chart_set()
Dim objCht As ChartObject
With ActiveSheet.ChartObjects(1).Chart.Axes(xlValue)
.MinimumScale = 0
.MaximumScale = my_max_var
End With
End Sub
is there any way to set the secondary one's as well?
First, the code below will Set objCht to the ChartObject in ActiveSheet (see here recommendation how to stay away from ActiveSheet How to avoid using Select in Excel VBA macros)
The code below will check if a secondary axis is applied, if not it will add it to the chart. Afterwards, it will modify the MinimumScale and MaximumScale to 20 and 50 (just random numbers I've selected).
Code
Option Explicit
Sub chart_set()
Dim objCht As ChartObject
Dim my_max_var As Long
' just for my tests
my_max_var = 1000
' set chart object
Set objCht = ActiveSheet.ChartObjects(1)
With objCht
With .Chart.Axes(xlValue, xlPrimary)
.MinimumScale = 0
.MaximumScale = my_max_var
End With
' check if Secondary Axis is applied
If .Chart.HasAxis(xlValue, xlSecondary) = False Then
.Chart.HasAxis(xlValue, xlSecondary) = True
End If
' modify minimum and maximum values of seconday axis
With .Chart.Axes(xlValue, xlSecondary)
.MinimumScale = 20
.CrossesAt = 20
.MaximumScale = 50
End With
End With
End Sub
When I use the below macro it only works for one series data set. How can I adapt it so that I can include multiple series?
Currently if I try and use it to label a second set it will delete the first one and so on...
Thanks in advance
Sub AddXYLabels()
If Left(TypeName(Selection), 5) <> "Chart" Then
MsgBox "Please select the chart first."
Exit Sub
End If
Set StartLabel = _
Application.InputBox("Click on the cell containing the first(top) label", Type:=8)
Application.ScreenUpdating = False
For Each pt In ActiveChart.SeriesCollection(1).Points
pt.ApplyDataLabels xlDataLabelsShowValue
pt.DataLabel.Caption = StartLabel.Value
Set StartLabel = StartLabel.Offset(1)
Next
End Sub
Your code is not working for rest of the series since you have hard coded the range for only one series
For Each pt In ActiveChart.SeriesCollection(1).Points
Please try this
Sub AddXYLabels()
If Left(TypeName(Selection), 5) <> "Chart" Then
MsgBox "Please select the chart first."
Exit Sub
End If
Dim mySeries As Series
Dim seriesCol As SeriesCollection
Dim I As Integer
I = 1
Set seriesCol = ActiveChart.SeriesCollection
For Each mySeries In seriesCol
Set mySeries = ActiveChart.SeriesCollection(I)
With mySeries
.ApplyDataLabels xlDataLabelsShowValue
End With
I = I + 1
Next
End Sub
This is an example I contrived, I created this to explain the problem I'm having. Basically I want this code to run faster than it does. On a new sheet each loop of a cell starts fast, but if you let it run to near completion, and then run it again, it will hit 100ms per cell. In my sheet I have 16000 cells with a lot of comments like this, and they are manipulated individually every time the code runs. In this example they are obviously all the same, but in the real application each one is different.
Is there anyway to make this process faster?
Option Explicit
Public Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long
Public Sub BreakTheCommentSystem()
Dim i As Integer
Dim t As Long
Dim Cell As Range
Dim dR As Range
Set dR = Range(Cells(2, 1), Cells(4000, 8))
Dim rStr As String
rStr = "ABCDEFG HIJK LMNOP QRS TUV WX YZ" & Chr(10)
For i = 1 To 5
rStr = rStr & rStr
Next i
For Each Cell In dR
t = GetTickCount
With Cell
If .Comment Is Nothing Then
.AddComment
Else
With .Comment
With .Shape.TextFrame.Characters.Font
.Bold = True
.Name = "Arial"
.Size = 8
End With
.Shape.TextFrame.AutoSize = True
.Text rStr
End With
End If
End With
Debug.Print (GetTickCount - t & " ms ")
Next
rStr = Empty
i = Empty
t = Empty
Set Cell = Nothing
Set dR = Nothing
End Sub
Update 12-11-2015, I wanted this noted somewhere in case anyone runs into it, the reason I was trying to optimize this so much was because VSTO would not let me add a workbook file with all these comments. After 6 months of working with Microsoft, this is now a confirmed bug in the VSTO and Excel.
https://connect.microsoft.com/VisualStudio/feedback/details/1610713/vsto-hangs-while-editing-an-excel-macro-enabled-workbook-xlsm-file
According to the MSDN Comments collection and Comment object documentation, you can reference all comments within a worksheet through their indexed position and deal with them directly rather than cycle through each cell and determine whether it contains a comment.
Dim c As Long
With ActiveSheet '<- set this worksheet reference properly!
For c = 1 To .Comments.Count
With .Comments(c)
Debug.Print .Parent.Address(0, 0) ' the .parent is the cell containing the comment
' do stuff with the .Comment object
End With
Next c
End With
Also according to official docs for the Range.SpecialCells method you can easily determine a subset of cells in a worksheet using the xlCellTypeComments constant as the Type parameter.
Dim comcel As Range
With ActiveSheet '<- set this worksheet reference properly!
For Each comcel In .Cells.SpecialCells(xlCellTypeComments)
With comcel.Comment
Debug.Print .Parent.Address(0, 0) ' the .parent is the cell containing the comment
' do stuff with the .Comment object
End With
Next comcel
End With
I'm still unclear with the reasoning behind filling all non-commented cells with a blank comment but if you are trying to work with the comments only on a worksheet it is better to work with the subset of commented cells rather than cycling through all cells looking for a comment.
By turning off screen updating, I was able to reduce the time for each iteration from around 100ms to around 17ms. You can add the following to the start of the procedure:
Application.ScreenUpdating = False
You can turn updating back on at the end of the procedure by setting it back to true.
This code copies the data to a new worksheet, and recreates all notes:
In a new user module:
Option Explicit
Private Const MAX_C As Long = 4000
Private Const MAIN_WS As String = "Sheet1"
Private Const MAIN_RNG As String = "A2:H" & MAX_C
Private Const MAIN_CMT As String = "ABCDEFG HIJK LMNOP QRS TUV WX YZ"
Public Sub BreakTheCommentSystem_CopyPasteAndFormat()
Dim t As Double, wsName As String, oldUsedRng As Range
Dim oldWs As Worksheet, newWs As Worksheet, arr() As String
t = Timer
Set oldWs = Worksheets(MAIN_WS)
wsName = oldWs.Name
UpdateDisplay False
RemoveComments oldWs
MakeComments oldWs.Range(MAIN_RNG)
Set oldUsedRng = oldWs.UsedRange.Cells
Set newWs = Sheets.Add(After:=oldWs)
oldUsedRng.Copy
With newWs.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormulasAndNumberFormats
.Cells(1, 1).Copy
.Cells(1, 1).Select
End With
arr = GetCommentArrayFromSheet(oldWs)
RemoveSheet oldWs
CreateAndFormatComments newWs, arr
newWs.Name = wsName
UpdateDisplay True
InputBox "Duration: ", "Duration", Timer - t
'272.4296875 (4.5 min), 269.6796875, Excel 2007: 406.83203125 (6.8 min)
End Sub
.
Other functions:
Public Sub UpdateDisplay(ByVal state As Boolean)
With Application
.Visible = state
.ScreenUpdating = state
'.VBE.MainWindow.Visible = state
End With
End Sub
Public Sub RemoveSheet(ByRef ws As Worksheet)
With Application
.DisplayAlerts = False
ws.Delete
.DisplayAlerts = True
End With
End Sub
'---------------------------------------------------------------------------------------
Public Sub MakeComments(ByRef rng As Range)
Dim t As Double, i As Long, cel As Range, txt As String
txt = MAIN_CMT & Chr(10)
For i = 1 To 5
txt = txt & txt
Next
For Each cel In rng
With cel
If .Comment Is Nothing Then .AddComment txt
End With
Next
End Sub
Public Sub RemoveComments(ByRef ws As Worksheet)
Dim cmt As Comment
'For Each cmt In ws.Comments
' cmt.Delete
'Next
ws.UsedRange.ClearComments
End Sub
'---------------------------------------------------------------------------------------
Public Function GetCommentArrayFromSheet(ByRef ws As Worksheet) As String()
Dim arr() As String, max As Long, i As Long, cmt As Comment
If Not ws Is Nothing Then
max = ws.Comments.Count
If max > 0 Then
ReDim arr(1 To max, 1 To 2)
i = 1
For Each cmt In ws.Comments
With cmt
arr(i, 1) = .Parent.Address
arr(i, 2) = .Text
End With
i = i + 1
Next
End If
End If
GetCommentArrayFromSheet = arr
End Function
Public Sub CreateAndFormatComments(ByRef ws As Worksheet, ByRef commentArr() As String)
Dim i As Long, max As Long
max = UBound(commentArr)
If max > 0 Then
On Error GoTo restoreDisplay
For i = 1 To max
With ws.Range(commentArr(i, 1))
.AddComment commentArr(i, 2)
With .Comment.Shape.TextFrame
With .Characters.Font
If .Bold Then .Bold = False 'True
If .Name <> "Calibri" Then .Name = "Calibri" '"Arial"
If .Size <> 9 Then .Size = 9 '8
If .ColorIndex <> 9 Then .ColorIndex = 9
End With
If Not .AutoSize Then .AutoSize = True
End With
DoEvents
End With
Next
End If
Exit Sub
restoreDisplay:
UpdateDisplay True
Exit Sub
End Sub
Hope this helps
I think I found 2 ways to improve performance for your task
The code in your example runs for an average of 25 minutes, I got it down to 4.5 minutes:
Create a new sheet
Copy & paste all values from the initial sheet
Copy all comments to a 2 dimensional array (cell address & comment text)
Generates the same comments for the same cells on the new sheet, with the new format
This one is quite simple to implement and test, and is very specific to your case
From the description, you are processing the same comments over and over
The most expensive part is changing the font
With this adjustment it will only update the font for the new comments (existing ones are already using the font from previous processing, even if the text gets updated)
Try updating this part of the code in the actual file (it's not as effective for the example)
With .Shape.TextFrame
With .Characters.Font
If Not .Bold Then .Bold = True
If .Name <> "Arial" Then .Name = "Arial"
If .Size <> 8 Then .Size = 8
End With
If Not .AutoSize Then .AutoSize = True
End With
or:
With .Shape.TextFrame
With .Characters.Font
If Not .Bold Then
.Bold = True
.Name = "Arial"
.Size = 8
End If
End With
If Not .AutoSize Then .AutoSize = True
End With
Let me know if you're interested in the other option and I can provide the implementation
Turn off screen updating and if you not need to workboook to recalculate during the macro, setting the calculation to manual will really shave off some time. This will prevent every formula in your workbook for processing every time you alter a cell. These two functions allow me to crunch out rather large reports in a matter of seconds.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Of course, at the end of the macro, set them back to true and automatic
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic