I have my code below that takes in a range and converts it to a picture that I automatically save. The picture always is pasted in the top right. Is there a way to center the picture on the chart or even shrink the chart to fit only the picture size?
Sub topicture(Sendrng As range)
Dim xcht As Chart
Dim Sname As String
Sname = ActiveSheet.Name
Sendrng.CopyPicture xlScreen, xlPicture
Set xcht = Charts.Add
With xcht
.ChartArea.ClearContents
.Paste
.ChartArea.Left = (xcht.ChartArea.Width - .Width) / 2
.Export Filename:="CDrive\Photos\" & Sname & ".jpg", Filtername:="JPG"
.Delete
End With
End Sub
You can resize the chart if you put it on a worksheet:
Sub tester()
ExportRangePicture Range("B4:G20"), "C:\_Stuff\test1.jpg"
ExportRangePicture Range("B4:G4"), "C:\_Stuff\test2.jpg"
End Sub
Sub ExportRangePicture(Sendrng As Range, fPath As String)
Dim xcht
Sendrng.CopyPicture xlScreen, xlPicture
Set xcht = Sendrng.Parent.Shapes.AddChart
With xcht.Chart
Do While .SeriesCollection.Count > 0
.SeriesCollection(1).Delete
Loop
.Parent.Width = Sendrng.Width
.Parent.Height = Sendrng.Height
.Paste
.Export Filename:=fPath, Filtername:="JPG"
.Parent.Delete
End With
End Sub
Related
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.
So I loop through each chart using the following code:
Sub LoopThroughCharts()
Dim sht As Worksheet
Dim CurrentSheet As Worksheet
Dim cht As ChartObject
Application.ScreenUpdating = False
Application.EnableEvents = False
Set CurrentSheet = ActiveSheet
For Each sht In ActiveWorkbook.Worksheets
For Each cht In sht.ChartObjects
cht.Activate
'Do something with the chart...
ActiveChart.Legend.Select
Selection.Left = 108.499
Selection.Width = 405.5
Selection.Height = 36.248
Selection.Top = 201.85
Selection.Left = 63.499
Selection.Top = 330.85
ActiveChart.PlotArea.Select
Selection.Height = 246.69
Selection.Width = 445.028
Next cht
Next sht
CurrentSheet.Activate
Application.EnableEvents = True
This makes each chart a specific size and I was thinking that I can modify the following vba code to strip the word "Test: out of Test: abc the legend and then the resulting legend would be abc. I think that I can modify the following code, but I am not sure how to to do this. :
For i = ActiveChart.SeriesCollection.Count To 1 Step -1
If ActiveChart.Legend(i)= "Test: *" Then
ActiveChart.Legend(i) **what I think needs to be modified**
End If
Next i
In order to strip a specific word, you can
Replace the prefix using the function Replace()
Take the sub string using the function Mid()
Here's the demo code
Sub stripDemo()
Dim str As String
str = "Test: my legend"
Debug.Print Replace(str, "Test: ", "")
Debug.Print Mid(str, 7, Len(str) - 6)
End Sub
EDIT
So when the code is applied to chart, it becomes :
For Each sht In ActiveWorkbook.Worksheets
For Each cht In sht.ChartObjects
cht.Activate
' iterate the series collection
' replace the prefixe "Tests: " with ""
For Each sr In ActiveChart.SeriesCollection
If Len(sr.Name) > 6 And Left(sr.Name, 6) = "Test: " Then
sr.Name = Replace(sr.Name, "Test: ", "")
End If
Next sr
Next cht
Next sht
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 use a button (by clicking) to create a new sheet and insert a button on it, but I want to import codes to the new button (here is MyPrecodedButton).
Private Sub CommandButton1_Click()
Dim z As Integer
Dim wb As Workbook
Dim ws2 As Worksheet, wsnew As Worksheet
Set wb = ThisWorkbook
Set ws2 = wb.Sheets("Sheet2")
z = ws2.Cells(2, 1).Value
Set wsnew = Sheets.Add ' Declare your New Sheet in order to be able to work with after
wsnew.Name = "PIAF_Summary" & z
z = z + 1
With wsnew.Range("A1:G1")
.Merge
.Interior.ColorIndex = 23
.Value = "Project Name (To be reviewed by WMO)"
.Font.Color = vbWhite
.Font.Bold = True
.Font.Size = 13
End With
ws2.Cells(2, 1).Value = z
Dim Rngc As Range: Set Rngc = wsnew.Range("F35")
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=Rngc.Left, Top:=Rngc.Top, Width:=205, Height:=20)
.Name = "MyPrecodedButton" ' change the name
End With
End sub
Here is the code for MyPrecodedButton
Public Sub MyPrecodedButton_Click()
MsgBox "Co-Cooo!"
End Sub
Let's demonstrate briefly what you can do with VBA to Add buttons.
Below code will Add a button to cell B2 if the ActiveSheet is not "Sheet1".
Option Explicit
Sub SayHello()
MsgBox "Hello from """ & ActiveSheet.Name & """"
End Sub
Sub AddButton()
Dim oRng As Range
Dim oBtns As Buttons ' Add "Microsoft Forms 2.0 Object Library" to References if you want intellisense
If ActiveSheet.Name <> "Sheet1" Then ' Only works if it's not "Sheet1"
Set oRng = Range("B2")
Set oBtns = ActiveSheet.Buttons
With oBtns.Add(oRng.Left * 1.05, oRng.Top * 1.05, oRng.Width * 0.9, oRng.Height * 2 * 0.9)
.Caption = "Say Hello!"
.OnAction = "SayHello"
End With
Set oBtns = Nothing
Set oRng = Nothing
End If
End Sub
Before and After screenshots:
Now Clicking on the button:
So, if you code is generic enough (to work with all your possible situations), there is no need to Add Codes via code. i.e. have your codes ready, then just assign the button's OnAction property to call the correct Sub.
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.