Displaying only a determined range of data - vba

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.

Related

Macro fires 50% of the time when changing slicer item

I have a particular problem and couldn't find any solution anywhere on the internet.
So I have a pivot table which is connected to 6 slicers and also a chart which data range is dependent on pivot table values.
I've made a macro which updates chart scales everytime a value in any of the worksheet cells is changed. Here is the macro:
Public Sub worksheet_Change(ByVal Target2 As Range)
If ActiveSheet.Name = "Dashboard" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DataEntryMode = xlOff
'Chart_axis Macro
Sheets("Dashboard").ChartObjects("Chart 9").Activate
If ActiveSheet.Range("B19") = "excluding CE" Then
ActiveChart.Axes(xlValue).MinimumScale = Range("E3").Value
ActiveChart.Axes(xlValue).MaximumScale = Range("E4").Value
Else
ActiveChart.Axes(xlValue).MinimumScale = Range("A3").Value
ActiveChart.Axes(xlValue).MaximumScale = Range("A4").Value
End If
ActiveChart.Refresh
ActiveSheet.Range("B18").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
In order to work as intended i also had to made a function which reads the active elements of a slicer:
Public Function GetSelectedSlicerItems(SlicerName As String) As String
Application.Volatile
Set coll = New Collection
Dim cache As Excel.SlicerCache
Dim i As Integer
Set cache = ActiveWorkbook.SlicerCaches(SlicerName)
Dim sItem As Excel.SlicerItem
Dim result As String
For Each sItem In cache.SlicerItems
If sItem.Selected And sItem.HasData Then
'Debug.Print sItem.Name
'Debug.Print sItem.HasData
'GetSelectedSlicerItems = (sItem.Name)
coll.Add sItem.Name
End If
Next sItem
For i = 1 To coll.Count
'Debug.Print coll(i)
result = result & coll(i) & ", "
Next i
result = Left(result, Len(result) - 2)
GetSelectedSlicerItems = result
End Function
My problem is that while the value of the function always updates when the slicer item is changed, the macro only does it randomly about 50% of the time.
Screenshot of my report:
The formulas containing the selected slicer items function are on the top right.
So do you have any idea how to make it work 100% of the time?
Thanks in advance,
Alan
Edit: i forgot to add that it's only the issue if only one slicer is highlited. When i select multiple slicers (with ctrl+click) it always works.

How to make a range bar chart

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.

How to prevent dropdown from executing when source list is changed programmatically

I have an activeX dropdown form on my spreadsheet which executes code on _Change. My code modifies the dropdowns list source (adding or deleting items). Whenever this happens, the _Change is called again.
I have various workarounds, all of which were some version of changing the list source, but with no success. The reason none of this has worked is because clearing or altering the .ListFillRange actually triggers the _Change event again.
How do I prevent the _Changeevent from getting called if I want to add or delete items in the .ListFillRange
UPDATE w EnableEvents set to false:
Public Sub SetRangeForDropdown()
On Error Resume Next
Application.EnableEvents = False
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
Application.EnableEvents = True
End Sub
Apperantly EnableEvents does not work for ActiveX controls.
Thank you Microsoft for making life just a little bit more complicated!
Just found this: "Application.EnableEvents=False/True ONLY applies to Sheet and Workbook Events, not ActiveX Control Events" from here enter link description here
You can disable the events in the SetRangeForDropdown and then enable them back.
So, write the following at the start:
Application.EnableEvents = False
And the following at the end:
Application.EnableEvents = true
it's always a good habit to make (nearly) sure that events handling is always brought back, like follows:
Public Sub SetRangeForDropdown()
'...your code
On Error GoTo ExitSub
Application.EnableEvents = False
wsMA.cmbEmployeeSelection.ListFillRange = rng2
'Update employee list named formula
ActiveWorkbook.Names.Add name:="nfEmployeeList", RefersTo:=rng2
ExitSub:
Application.EnableEvents = True
End Sub
Furthermore, avoid On Error Resume Next unless you really need it
I have solved the problem by adding a global variable that prevents the _Change event from firing. Here is that code:
Private Sub cmbEmployeeSelection_Change()
If bNOTRUN = False Then 'Check if ActiveX event should fire or not
modEmployeeDB.SaveEmployeeData 'Save currently selected employee data
modEmployeeDB.DBSoll_To_WorkerInfo 'Get called employee data
End If
End Sub
And this is the module as modified... note the simple Boolean variable that I added:
Public Sub SetRangeForDropdown()
On Error GoTo SetRangeForDropdown_Error
bNOTRUN = True 'Global Variable that when True prevents Active X from firing
'Get new List of employees from Employee sheet
Dim rng1 As Range
With wsDB_employee
Set rng1 = .Range("A2:B" & .Range("A10000").End(xlUp).Row)
End With
With wsStage
.Cells.Clear
rng1.Copy .Range(.Cells(1, 1), .Cells(rng1.Rows.Count, 2))
End With
'Set range for dropdown on employee sheet
Dim rng2 As Range
Set rng2 = wsStage.Range("A1:B" & wsStage.Range("A10000").End(xlUp).Row)
'Update employee list named formula
ActiveWorkbook.Names.Add Name:="nfEmployeeList", RefersTo:=rng2
Dim str As String
str = rng2.Parent.Name & "!" & rng2.Address 'Source path for list fill range
wsMA.cmbEmployeeSelection.ListFillRange = str
bNOTRUN = False
On Error GoTo 0
Exit Sub
SetRangeForDropdown_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SetRangeForDropdown of Sub modEmployeeDB"
bNOTRUN = False
End Sub

How can I import code to a Activex Control Button on another page?

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.

Pasting chart fails when outside of viewable screen area

Whilst this proven method has worked for people and works for me in the general sense, I receive "Error 1004: Method 'Paste' of object '_Chart' failed." However, on the 5th iteration of the loop this method failure occurs. I have tried isolating each component of the Array and the 6th and 7th elements always fail, but when the 5th element is used in isolation or as the starting point of the loop it succeeds. I have also tried clearing the clipboard at different stages of the process to see if that helps and tested the object property of the "cht" object.
Sub PicturesCopy()
'Define path variables
Path = "C:\Users\khill\Documents\Macro Tests\"
PathSC = Path & "Master Cockpit\"
FileMCP = "Master_Daily sales cockpit.xlsm"
Set wbMCP = Workbooks(FileMCP)
Dim cht As ChartObject
Dim rngList, fileList As Variant
rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139")
fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b")
For x = 0 To UBound(rngList)
'Application.CutCopyMode = True
With wbMCP.Worksheets("Graphs")
Debug.Print rngList(x)
Dim rgExp As Range: Set rgExp = .Range(rngList(x))
Debug.Print x
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
''' Create an empty chart with exact size of range copied
Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
cht.Name = "PicChart"
With cht
.Chart.Paste
Debug.Print fileList(x)
.Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg"
.Delete
'Application.CutCopyMode = False
End With
Set cht = Nothing
Set rgExp = Nothing
Next x
End Sub
Have you tried using a clipboard viewer to verify that the rgExp.CopyPicture operation has done what you expect when Debug.Print x shows 5 (6th iteration)?
Assuming you are using some version of Windows, there are some tips on how to view clipboard here, depending on version:
View & Manage Clipboard In Windows 10 / 8 / 7
http://www.thewindowsclub.com/windows-clipboard-manager-viewer
Ok. I found the problem. The charts have to be contained within the viewable screen to be pasted by the clipboard. so you can either zoom out (not ideal because the images are saved small and therefore pixelated) or zoom to the new Chart area/select the position where the chart object is placed in the first place. My solution was to zoom to the range. Adjusted Code is below. Hope this helps someone else :)
Sub PicturesCopy()
'Define path variables
Path = "C:\Users\khill\Documents\Macro Tests\"
PathSC = Path & "Master Cockpit\"
FileMCP = "Master_Daily sales cockpit.xlsm"
Set wbMCP = Workbooks(FileMCP)
Dim cht As ChartObject
Dim rngList, fileList As Variant
rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139")
fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b")
For x = 0 To UBound(rngList)
'Application.CutCopyMode = True
With wbMCP.Worksheets("Graphs")
Debug.Print rngList(x)
Dim rgExp As Range: Set rgExp = .Range(rngList(x))
Debug.Print x
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
''' Create an empty chart with exact size of range copied
Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
cht.Name = "PicChart"
'Use ZoomToRange sub to re-size the window as appropriate
ZoomToRange ZoomThisRange:=Range(rngList(x)), PreserveRows:=True
With cht
.Chart.Paste
Debug.Print fileList(x)
.Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg"
.Delete
'Application.CutCopyMode = False
End With
Set cht = Nothing
Set rgExp = Nothing
Next x
End Sub
The ZoomToRange macro that is called in the above is as follows:
Sub ZoomToRange(ByVal ZoomThisRange As Range, _
ByVal PreserveRows As Boolean)
'###################################
'This macro resizes the window and''
'zoom properties to be appropriate''
'for our use''''''''''''''''''''''''
'###################################
'Turn alerts and screen updating off
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Declare variable type
Dim Wind As Window
'Create variable for window
Set Wind = ActiveWindow
'Zooming to specified range set to true
Application.GoTo ZoomThisRange(1, 1), True
'Select the resized range
With ZoomThisRange
If PreserveRows = True Then
.Resize(.Rows.Count, 1).Select
Else
.Resize(1, .Columns.Count).Select
End If
End With
'Set zoom and visible range to specified range
With Wind
.Zoom = True
.VisibleRange(1, 1).Select
End With
End Sub