I have a code that modifies a chart layout, using a chart number that has to be modified as user input value. As far i have a lot of charts (about 50), i would like to imput not just 1 value per time, but to say to modify charts for example from 2 to 10. Can some one help with it, please?
Sub Grafici()
Dim ws As Worksheet
Dim sUserInput As String
Set ws = ActiveWorkbook.Sheets("Sheet1")
ws.Select
sUserInput = InputBox("Enter Number:", "Collect User Input")
For i = 1 To 7
On Error Resume Next
ActiveSheet.ChartObjects("Chart " & sUserInput).Activate
ActiveChart.SeriesCollection(i).Points(12).MarkerSize = 19
ActiveChart.SetElement (msoElementDataLabelCenter)
ActiveChart.SeriesCollection(i).Points(11).DataLabel.Delete
ActiveChart.SeriesCollection(i).Points(11).MarkerSize = 5
Next
End Sub
Thanks!
Related
I created several VBA functions and macros to automate my work, but as more data goes in, I'm noticing a larger delay in running my macros. Are there any things that I can change or alter in my code to improve its efficiency?
Premise of the program:
- Refresh button loops through all worksheets, changes colors based on their completion, and puts information of "Incomplete/Expired" forms in a table (slowest)
'===============
'Refresh Button on MASTER PAGE
'Functions: Updates color of sheets, based on completion/incompletion
' Removes inputs from MASTER page
' Updates Expired Forms cells
'====================
Sub refresh_form()
Dim ws As Worksheet
Dim wb As Workbook
Dim wsMASTER, wsTEMP
Dim complete, incomplete, exp, default 'to store color index's
Dim expName, expDate, expGSA, expStatus 'to store values for expired forms
Dim lastRow As Long 'to store row # for expired & incomplete form
'CLEARS DATA FROM MAIN SHEET
ThisWorkbook.Worksheets("MASTER").Range("C6").Value = "" 'Project name
ThisWorkbook.Worksheets("MASTER").Range("C7").Value = "" 'Address
ThisWorkbook.Worksheets("MASTER").Range("C8").Value = "" 'Date
ThisWorkbook.Worksheets("MASTER").Range("C9").Value = "" 'GSA #
ThisWorkbook.Worksheets("MASTER").Range("C10").Value = "" 'Exp Date
wsMASTER = "MASTER" 'Sets wsMASTER as MASTER worksheet
wsTEMP = "TEMPLATE" 'Sets wsTEMP as TEMPLATE worksheet
complete = 4 'Green
incomplete = 44 'Orange
default = 2 'White
exp = 3 'Red
lastRow = 5 'Expired & Incomplete row starts at 5
For Each ws In ThisWorkbook.Worksheets 'Loops through all worksheets on click
If ws.Name = wsMASTER Or ws.Name = wsTEMP Then 'For MASTER and TEMPLATE sheet, skip
ws.Tab.ColorIndex = default
ElseIf ws.Range("$M12").Value = True And ws.Range("$M$15").Value = True Then 'Applies "Exp" tab color to expired/incomp forms
ws.Tab.ColorIndex = exp
expName = ws.Range("$C$5").Value 'Stores current form's project name
expDate = ws.Range("$C$9").Value '***expiration date
expGSA = ws.Range("$C$8").Value '***GSA number
lastRow = lastRow + 1 'increments lastRow by a value of 1
'VALUES INPUTTED IN EXPIRED & INCOMPLETE FORM
ThisWorkbook.Worksheets("MASTER").Range("K" & lastRow).Value = expGSA ' GSA #
ThisWorkbook.Worksheets("MASTER").Range("L" & lastRow).Value = expName ' Project name
ThisWorkbook.Worksheets("MASTER").Range("M" & lastRow).Value = expDate ' Expiration date
ElseIf ws.Range("$M$12").Value = True Then 'Applies "Incomplete" tab color to incomplete forms
ws.Tab.ColorIndex = incomplete
ElseIf ws.Range("$M$12").Value = False And ws.Range("$N$12").Value = True Then 'Applies "Complete" tab color to complete forms
ws.Tab.ColorIndex = complete
Else 'Applies "Default" tab color to any untouched forms
ws.Tab.ColorIndex = default
End If
Next ws 'End Loop
End Sub 'End Sub
This question is probably best answered at Code Review, but a simple way to increase performance would be to do something like below:
'===============
'Refresh Button on MASTER PAGE
'Functions: Updates color of sheets, based on completion/incompletion
' Removes inputs from MASTER page
' Updates Expired Forms cells
'====================
Sub refresh_form()
Dim ws As Worksheet
Dim wsMaster As Worksheet: Set wsMaster = Worksheets("MASTER")
Dim wb As Workbook
Dim wsTEMP As String
Dim complete As Integer, incomplete As Integer, exp As Integer, default As Integer 'to store color index's
Dim lastRow As Long 'to store row # for expired & incomplete form
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'CLEARS DATA FROM MAIN SHEET
wsMaster.Range("C6:C10").ClearContents
complete = 4 'Green
incomplete = 44 'Orange
default = 2 'White
exp = 3 'Red
lastRow = 5 'Expired & Incomplete row starts at 5
For Each ws In ThisWorkbook.Worksheets 'Loops through all worksheets on click
If ws.Name = wsMaster.Name Or ws.Name = "TEMPLATE" Then 'For MASTER and TEMPLATE sheet, skip
ws.Tab.ColorIndex = default
ElseIf ws.Range("$M12").Value = True And ws.Range("$M$15").Value = True Then 'Applies "Exp" tab color to expired/incomp forms
ws.Tab.ColorIndex = exp
lastRow = lastRow + 1 'increments lastRow by a value of 1
wsMaster.Range("K" & lastRow).Value = ws.Range("$C$8").Value 'GSA #
wsMaster.Range("L" & lastRow).Value = ws.Range("$C$5").Value 'Project name
wsMaster.Range("M" & lastRow).Value = ws.Range("$C$9").Value 'Expiration date
ElseIf ws.Range("$M$12").Value = True Then 'Applies "Incomplete" tab color to incomplete forms
ws.Tab.ColorIndex = incomplete
ElseIf ws.Range("$M$12").Value = False And ws.Range("$N$12").Value = True Then 'Applies "Complete" tab color to complete forms
ws.Tab.ColorIndex = complete
Else 'Applies "Default" tab color to any untouched forms
ws.Tab.ColorIndex = default
End If
Next ws 'End Loop
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Add this to the beginning of your code below your DIMs
Application.calculation=xlcalculationmanual
application.screenupdating=false
application.displaystatusbar=false
application.enableevents=false
then add this at the end of your code before end sub
Application.calculation=xlcalculationautomatic
application.screenupdating=true
application.displaystatusbar=true
application.enableevents=true
This should help speed up your code.
The majority of your macro is not doing anything extremely intensive. The most intensive operation Excel is doing is updating the UI when it switches between worksheets. You may see a significant improvement if you temporarily disable UI updating.
Before you enter your For Each loop, call
Application.ScreenUpdating = False
And before your Sub Routine exits, restore screen updating
Application.ScreenUpdating = True
There is not a lot else you can do to improve the performance of the code. Other optimization options would be to keep the number of Worksheets to a minimum, or using multiple Workbooks.
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.
I am creating charts using data from a tabs called Team1-Team8. I am creating the charts for each team ok but I can't get the charts into each team tab called "Team a - Charts". Below is the code i have so far for just Team A.My Parameter sheet, Column B has the names of the tabs for the charts and Column A is the Team names. Any pointers would help.
Sub LooproutineCharts()
Dim TeamName As String
Dim TeamNameCharts As String
For i = 4 To 12
TeamName = Sheets("Parameter").Range("A" & i).Value 'identify the location
TeamNameCharts = Sheets("Parameter").Range("B" & i).Value 'identify the location
Call Charts(TeamName) ' Call subroutine
Call Charts(TeamNameCharts) ' Call subroutine
Next i
End Sub
Sub Charts(TeamName As String)
'Create a Line Chart for Healthy Start Docu'
Dim lastRow As Long
Dim ws As Worksheet
Set ws = Sheets(TeamName)
With Sheets(TeamName)
lastRow = .Range("U" & Rows.count).End(xlUp).Row
With ws
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLineMarkers
ActiveChart.Parent.Name = "Variable A"
ActiveChart.SetSourceData Source:=.Range("S3:U" & lastRow)
ActiveSheet.Shapes("Variable A").Top = 20
ActiveSheet.Shapes("Variable A").Left = 20
ActiveSheet.Shapes("Variable A").Height = 300
ActiveSheet.Shapes("Variable A").Width = 700
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = "Variable A" TeamName"
End With
End With
End Sub
I would suggest updating the Charts Sub to make use of Worksheet.ChartObjects
Using the ChartObject, you can set it and won't have to reference a shape by name. It would look like this:
Sub Charts(TeamName As String)
'Create a Line Chart for Healthy Start Docu'
Dim theChart As ChartObject
Dim lastRow As Long
Dim ws As Worksheet
Set ws = Sheets(TeamName)
With ws
lastRow = .Range("U" & Rows.Count).End(xlUp).Row
Set theChart = .ChartObjects.Add(Left:=20, Top:=20, Width:=700, Height:=300)
With theChart.Chart
.ChartType = xlLineMarkers
.SeriesCollection.Add Source:=ws.Range("S3:U" & lastRow)
'.SeriesCollection(1).XValues = ws.Range("S2:U2") 'I have no idea where your xaxis is placed, or if it exist
.HasTitle = True
.ChartTitle.Text = TeamName
End With
End With
End Sub
I've taken the liberty to assume that the chart title should match the TeamName argument. I've also made it ready for the xAxis, but I have no oidea if it is relevant, or where it is placed
I have wrote some VBA code which I was fairly happy with. It went through a list on a worksheet, switched to another and set a variable (and thus changed some graphs) and then opened word, copied in the graphs to various bookmarks and saved the document as the variable name.
It worked like a charm and I was a happy boy (saved a good week and a bit of work for someone). I have not touched it since - or the worksheets for that matter - opened it today and it is giving me a type missmatch on the first lot. I would really love some advice as it has left me scratching my head.
Public X As Integer
Public Y As String
Sub Macro2()
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Sheets("CPD data 13-14").Select
Range("A" & LoopCounter).Select
Y = Range("A" & LoopCounter).Value
'Change the chart values
Sheets("Pretty Display (2)").Select
Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
The error hits on the following line:
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
EDIT
As suggested I have updated my code not to use select so it now reads:
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
'Change the chart values
pd.Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = pd.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
I still get the same runtime error at the same point.
try this
Option Explicit
Public X As Integer
Public Y As String
Sub Macro2()
Dim wordApp As Object
Dim LoopCounter As Integer
Dim Mystring As String
Dim ws As Worksheet, pd As Worksheet
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
' open one Word session for all the documents to be processed
Set wordApp = CreateObject("word.Application")
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
With pd
.Range("A1").Value = Y 'Change the chart values
.ChartObjects("Chart 3").Copy ' Copy the chart
End With
'act on Word application
With wordApp
'open word template
.documents.Open "LOCATION"
.Visible = True
' paste into bookmarks, "save as" document and close it
With .ActiveDocument
.Bookmarks("InstitutionName").Range = Y
.Bookmarks("Graph1").Range.PasteSpecial
Mystring = Replace(Y, " ", "")
.SaveAs Filename:="LOCATION" & Mystring & ".docx"
.Close
End With
End With
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
'Close Word
wordApp.Quit
Set wordApp = Nothing
End Sub
I couldn't have a word "Range" object directly set to an Excel "Chart" object
So I had to copy the chart and use "PasteSpecial" method of the Word "Range" object
Furthemore I worked with one Word session only, which'd result in a faster job
Finally I also made some "comsetics" to make the code more readable/maintanable
just as a suggestion: I'd always use "Option Explicit" statement. that'll force you some extra work to explicitly declare each and every variable you use, but that will also give much more control over your work and result in less debbugging issues, thus saving time at the end
My advice is to set the Explicit flag and try to decompile the code. Any variables that you didn't dimension will throw an error. This is a good time to dimension the variable and type the data appropriately.
If that doens't throw an error, which it should since you have at least one variable LoopCounter that isn't dimensioned and could therefore cause data type errors then try changing Public X As Integer to Public X As Long so as to avoid values beyond the limit of the Integer data type.
.Activate is sometimes necessary even when using .Select from my experience. Selecting a worksheet should make it the active worksheet, but that's not always the case.
I want to display to the user certain information that exists on a separated worksheet, whenever he clicks a button.
I can set Excel to "go" to this worksheet at the starting line of the range , but I could not find a way to hide everything else.
Is there some method for this, or do I have to hide all rows and columns?
Insert a UserForm in the Workbook's VB Project.
Add a ListBox control to the userform.
Then do something like this code in the UserForm_Activate event code:
Private Sub UserForm_Activate()
Dim tbl As Range
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
Me.Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With ListBox1
.ColumnHeads = False
.ColumnCount = tbl.Columns.Count
.RowSource = tbl.Address
End With
End Sub
Which gives unformatted data from the range:
To export the range as an image, you could create an Image in the UserForm instead of a Listbox. Then this should be enough to get you started.
As you can see from this screenshot, the image might not always come out very clearly. Also, if you are working with a large range of cells, the image might not fit on your userform, etc. I will leave figuring that part out up to you :)
Private Sub UserForm_Activate()
Dim tbl As Range
Dim imgPath As String
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
imgPath = Export_Range_Images(tbl)
Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With Image1
If Not imgPath = vbNullString Then
.Picture = LoadPicture(imgPath)
.PictureSizeMode = fmPictureSizeModeClip
.PictureAlignment = 2 'Center
.PictureTiling = False
.SpecialEffect = 2 'Sunken
End If
End With
End Sub
Function Export_Range_Images(rng As Range) As String
'## Modified by David Zemens with
' credit to: _
' http://vbadud.blogspot.com/2010/06/how-to-save-excel-range-as-image-using.html ##'
Dim ocht As Object
Dim srs As Series
rng.CopyPicture xlScreen, xlPicture
ActiveSheet.Paste
Set ocht = ActiveSheet.Shapes.AddChart
For Each srs In ocht.Chart.SeriesCollection
srs.Delete
Next
'## Modify this line as needed ##'
fname = "C:\users\david_zemens\desktop\picture.jpg"
On Error Resume Next
Kill fname
On Error GoTo 0
ocht.Width = rng.Width
ocht.Height = rng.Height
ocht.Chart.Paste
ocht.Chart.Export Filename:=fname, FilterName:="JPG"
Application.DisplayAlerts = False
ocht.Delete
Application.DisplayAlerts = True
Set ocht = Nothing
Export_Range_Images = fname
End Function
If you record a macro and hide some columns and rows manually, the code will be produced for you, and you will see how it's done.