Passing a dynamic range to charts - excel

I want to check the status of a sheet and when changed automatically run some calculations. I also wish refresh a graph with the new data from that sheet.
I used the Worksheet_Change function. It calls the sub with the calculations and calls the sub that contains the chart modification code. They run as planned with one exception. The range that gets passed to the Chrt1 sub (responsible for the chart functionality) does not get updated on the graph once it has been called out for the first time.
I'm aware that this can be overcome with Excel built-in tables function but I'd like to code this simple routine in anyways.
The Worksheet_Change function:
Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
AutoChangeTest
Application.EnableEvents = True
End Sub
The main module code:
Sub AutoChangeTest()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, j As Integer, lrow As Integer, lrow2 As Integer
Set s1 = Sheets("Arkusz3")
On Error GoTo Err1
lrow = s1.Cells(s1.Rows.Count, 1).End(xlUp).Row
For i = 1 To lrow
s1.Cells(i, 2) = s1.Cells(i, 1) * 2
Next
Call Chrt1(Range(s1.Cells(1, 1), s1.Cells(lrow, 2)), s1)
Err1:
If Not IsNumeric(s1.Cells(i, 1)) Then
s1.Cells(i, 1).Activate
End If
End Sub
Sub Chrt1(r1 As Range, s1 As Worksheet)
Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer
i = 0
Set r = r1
Set s = s1
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
c1.Chart.SetSourceData (r)
End Sub

Some suggestions in the code below:
Sub AutoChangeTest()
Dim ws As Worksheet 'avoid variable names with 1/l - too unclear
Dim i As Long, lrow As Long 'always use long over integer
Set ws = ThisWorkbook.Worksheets("Arkusz3")
lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
On Error GoTo exitHere
Application.EnableEvents = False 'don't re-trigger this sub...
For i = 1 To lrow
With ws.Cells(i, 1)
'easier to test than to trap an error if non-numeric
If IsNumeric(.Value) Then
ws.Cells(i, 2) = .Value * 2
Else
ws.Select
.Select
MsgBox "Non-numeric value found!"
GoTo exitHere 'acceptable use of Goto I think
End If
End With
Next
'don't think you need a separate method for this...
If ws.ChartObjects.Count = 0 Then ws.Shapes.AddChart 'no need to loop for a count
'assuming there will only be one chart...
ws.ChartObjects(1).Chart.SetSourceData ws.Range(ws.Cells(1, 1), ws.Cells(lrow, 2))
exitHere:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub

In your Chrt1 procedure, this bit
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
can be replaced by the following:
If s.ChartObjects.Count = 0 Then
Set c1 = s.Shapes.AddChart
End If
But what is c1 if you don't have to add a chart? You haven't defined it, and the On Error means you never find out that it's broken.
Assuming you want the last chart object to be the one that is changed:
If s.ChartObjects.Count = 0 Then
Set c1 = s.Shapes.AddChart
Else
Set c1 = s.ChartObjects(s.ChartObjects.Count)
End If
And you should declare c1 as a ChartObject.
Finally, remove the parentheses around r in this line:
c1.Chart.SetSourceData r

Thank you all for support. The basic code that works is shown below. It isn't the best looking but it does the job.
Sub Chrt1(r1 As Range, s1 As Worksheet)
Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer
i = 0
Set r = r1
Set s = s1
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
Set cht = s.ChartObjects(1)
cht.Chart.SetSourceData Source:=r
End Sub

Related

How to avoid error #NA when executing my macro

I have this error with my macro. My macro takes data from a table and in another sheet, outputs in a table my data for each value of a third sheet.
So let's say my table's value are : Jack and Daniel. And on my third sheet, I have Football and Rugby. The output in the second page will be :
Jack Football
Jack Rugby
Daniel Football
Daniel Rugby
Here is my macro :
Sub yo()
Dim Letters, Chk, Ele As Range, i As Long: Letters = Sheets("Sports").Range("C3:C5").Value
For Each Ele In Sheets("Students").ListObjects(1).ListColumns(1).DataBodyRange
With Sheets("OK").ListObjects(1)
Chk = Application.Match(Ele, .ListColumns(1).Range, 0)
If IsError(Chk) Then
For i = 1 To 3
.ListRows.Add.Range = Array(Ele, Letters(i, 1))
Next i
End If
End With
Next Ele
End Sub
However this works fine. The problem comes from all the other columns of the table in my second sheet. They all get the value "#NA". So instead of having nothing or formulas expanding down, there is that error.
How can I overcome this error ?
Copy to Excel Table (ListObject)
The short answer is that in this case a ListRow has four columns yet you're assigning it an array of only two. By the looks of your answer, you have concluded this yourself (.Resize(, 2)).
An Improvement
Option Explicit
Sub AddStudents()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsSports As Worksheet: Set wsSports = wb.Sheets("Sports")
Dim Sports(): Sports = wsSports.Range("C3:C5").Value
Dim SportsCount As Long: SportsCount = UBound(Sports, 1)
Dim wsStudents As Worksheet: Set wsStudents = wb.Sheets("Students")
Dim loStudents As ListObject: Set loStudents = wsStudents.ListObjects(1)
Dim lcStudents As ListColumn: Set lcStudents = loStudents.ListColumns(1)
Dim rgStudents As Range: Set rgStudents = lcStudents.DataBodyRange
Dim wsOK As Worksheet: Set wsOK = wb.Sheets("OK")
Dim loOK As ListObject: Set loOK = wsOK.ListObjects(1)
Dim lcOK As ListColumn: Set lcOK = loOK.ListColumns(1)
Dim rgOK As Range: Set rgOK = lcOK.DataBodyRange
Dim cell As Range, Student, MatchOK, r As Long, IsNotStudentAdded As Boolean
For Each cell In rgStudents.Cells
If rgOK Is Nothing Then
IsNotStudentAdded = True
Else
MatchOK = Application.Match(cell.Value, rgOK, 0)
If IsError(MatchOK) Then IsNotStudentAdded = True
End If
If IsNotStudentAdded Then
Student = cell.Value
For r = 1 To SportsCount
loOK.ListRows.Add.Range.Resize(, 2).Value _
= Array(Student, Sports(r, 1))
Next r
IsNotStudentAdded = False
Set rgOK = lcOK.DataBodyRange
End If
Next cell
MsgBox "Students added.", vbInformation
End Sub
So I decided to completely change my macro to avoid any error :
Sub Macro7()
Dim N, S, i, j
Application.ScreenUpdating = False
N = Range("Tableau1"): S = Sheets("Sports").Range("C3:C5").Value
With Range("Tableau2").ListObject
If .ListRows.Count > 0 Then .DataBodyRange.Delete
For Each i In N
For Each j In S
.ListRows.Add.Range.Resize(, 2) = Array(i, j)
Next
Next
End With
End Sub

Looping through a range to find a value

I have a worksheet that has columns 1-8, rows 3 through the last row. I would like to loop through each cell to find out if a value of 1 is present. If it is then that row is copied and inserted for each value of 1, additionally that new row will have a text inserted in cell (13,row) then moved to the next row. This is as far as I got....thanks!
Sub Workcenter()
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
On Error GoTo 0
Dim Test As Worksheet
Set TS = Worksheets("Test")
Application.DisplayAlerts = True
For k = 1 To 8
For j = 4 To TS.Cells(Rows.Count, k).End(xlUp).Row
If TS.Cells(j, k).Value = 1 Then TS.Cells.Activate
'TS.Cells.Activate.Row.Select
Rows(ActiveCell.Row).Select
Selection.Copy
Selection.Insert Shift:=xlDown
'ShopOrderNumRow = j
Next j
Next k
End Sub
Will try giving some example knowing that I still don't understand how the inserting is occurring for each cell of a row.
Providing more detail, or example of before/after in your post may help.
As for an example, since you're marking only a single cell in each row, I would suggest Find() for value of 1 to determine if you need to write to that specific cell.
'untested code
sub test()
toggle false
dim rowNum as long
for rowNum = firstRow to lastRow Step 1
with sheets(1)
with .range(.cells(rowNum,1),.cells(rowNum,8))
dim foundCell as range
set foundCell = .find(1)
if not foundCell is nothing then .cells(rowNum,13).value = "text"
end with
end with
next iterator
toggle true
end sub
private sub toggle(val as boolean)
with application
.screenupdating = val
.enableevents = val
end with
end sub
Edit1: Looks like countif() may be the saviour here.
Edit2: Tested code input (untested code part of Edit1)
Sub test()
Dim lastRow As Long: lastRow = 10
Dim firstRow As Long: firstRow = 1
toggle False
Dim rowNum As Long
For rowNum = lastRow To firstRow Step -1
With Sheets(1)
Dim countRange As Range
Set countRange = .Range(.Cells(rowNum, 1), .Cells(rowNum, 8))
Dim countOfOnes As Long
countOfOnes = Application.CountIf(countRange, 1)
If countOfOnes > 0 Then
With .Rows(rowNum)
.Copy
.Offset(1).Resize(countOfOnes).Insert Shift:=xlDown
End With
.Cells(rowNum, 13).Value = "text"
End If
End With
Next rowNum
toggle True
End Sub
Private Sub toggle(val As Boolean)
With Application
.ScreenUpdating = val
.EnableEvents = val
End With
End Sub
Tested using this data:
Output from running code:

Getting error 'object variable or With block variable not set' when trying to run sub

I did not create the code but am trying to troubleshoot an excel file and the original author is not available (layed off from company and not willing to help).
The following line is generating the error, 'object variable or With block variable not set'
Private Sub Workbook_Open()
Sheet1.Starttimer
End Sub
I looked at Sheet1 code and found the below, so I'm not sure what the problem is:
Sub Starttimer()
Application.DisplayAlerts = False
If Not Sheet4.ListObjects(1).DataBodyRange Is Nothing Then
Sheet4.ListObjects(1).DataBodyRange.Rows.Delete
End If
ActiveWorkbook.RefreshAll
Application.Calculate
SetProductionZeros
ActiveWorkbook.Save
ThisWorkbook.Close
End Sub
UPDATE
After setting the debug to break on all errors, the line that causes the error appears to be "r = Sheet4.ListObjects(1).DataBodyRange.Rows.Count" from the sub below:
Sub SetProductionZeros()
Dim tb1 As ListObject
Dim x As Long
Dim y As Long
Dim r As Long
Dim c As Long
'Set path for Table variable'
Set tb1 = Sheet4.ListObjects(1)
Sheet4.Activate
r = Sheet4.ListObjects(1).DataBodyRange.Rows.Count
c = Sheet4.ListObjects(1).DataBodyRange.Columns.Count
'Loop Through Each DataBody Row in Table
For y = 1 To r
'Loop Through Each Column in Table
For x = 1 To c
If IsEmpty(Sheet4.ListObjects(1).DataBodyRange.Cells(y, x)) Then Sheet4.ListObjects(1).DataBodyRange.Cells(y, x) = 0
Next x
Next y
Sheet4.Columns(5).EntireColumn.Delete
Dim lastrow As Long, lastcol As Long, thiscol As Long
Dim totalrow As Long, totalcol As Long, thisrow As Long
totalrow = 7 + Sheet4.ListObjects(1).Range.Rows.Count
totalcol = 2 + Sheet4.ListObjects(1).Range.Columns.Count
On Error GoTo Errorcatch
'lastrow = Cells(Rows.Count, 1).End(xlUp).row
'lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Sheet4.Cells(totalrow, 3).Value = "Total"
For thiscol = 5 To totalcol - 1
Sheet4.Cells(totalrow, thiscol).Select
ActiveCell.Value = WorksheetFunction.Sum(Sheet4.Range(Sheet4.Cells(1, ActiveCell.Column), ActiveCell))
Next
Sheet4.Rows(totalrow).Font.Bold = True
Sheet4.Cells(7, totalcol).Value = "Total"
For thisrow = 8 To totalrow
Sheet4.Cells(thisrow, totalcol).Select
ActiveCell.Value = WorksheetFunction.Sum(Sheet4.Range(Sheet4.Cells(ActiveCell.row, 5), ActiveCell))
Next
Sheet4.Columns(totalcol).Font.Bold = True
'Sheet4.Columns(2).HorizontalAlignment = xleft
For y = totalrow To 8 Step -1
If Sheet4.Cells(y, 2) = "T" And Sheet4.Cells(y, totalcol).Value = 0 Then
Sheet4.Rows(y).EntireRow.Delete
End If
Next
Exit Sub
Errorcatch:
MsgBox Err.Description
End Sub
Follow the logic:
When you open the workbook, you call Sheet1.StartTimer
Sheet1.StartTimer includes
If Not Sheet4.ListObjects(1).DataBodyRange Is Nothing Then
Sheet4.ListObjects(1).DataBodyRange.Rows.Delete
End If
At this point Sheet4.ListObjects(1).DataBodyRange will be Nothing (because you deleted all its rows)
Then you call SetProductionZeros
SetProductionZeros includes r = Sheet4.ListObjects(1).DataBodyRange.Rows.Count
But because Sheet4.ListObjects(1).DataBodyRange is Nothing this throws an error. (Same applies to .Columns.Count)
You can wrap references to DataBodyRange in
If Not Sheet4.ListObjects(1).DataBodyRange Is Nothing Then
' ...
End If
but you need to consider what you want to achieve when there are no rows in Sheet4.ListObjects(1)
This error seems to indicate that you are assigning an object to r without set. Nothing is an object. So in your case you are likely getting Nothing from Sheet4.ListObjects(1).DataBodyRange.Rows.Count. After Set tb1 = Sheet4.ListObjects(1), verify that tb1 is not nothing.
FYI, For code clarity, you should be using r = tb1.DataBodyRange.Rows.Count (same for c =).

Dynamically update the count of selected CheckBox in Excel using VBA

I am trying to find out a way to update the count of the selected checkboxes in excel using VBA.
i.e as the user selects the checkbox, the count has to get updated across the relevant filed. For example, If I select first check box ABC/18-49. The count at the top for (18-49) should get updated to 3.
P.S: This is how I have created the checkboxes dynamically.
Sub Main()
Dim Rng As Range
Dim WorkRng As Range
Dim Ws As Worksheet
On Error Resume Next
Set Ws = ThisWorkbook.Sheets(1)
Ws.Range("A:A").Insert
Set WorkRng = Ws.Range("A2:A" & Ws.UsedRange.Rows.Count)
Application.ScreenUpdating = False
For Each Rng In WorkRng
With Ws.CheckBoxes.Add(Rng.Left, Rng.Top, Rng.Width, Rng.Height)
.Characters.Text = "Yes"
End With
Next
WorkRng.ClearContents
WorkRng.Select
Application.ScreenUpdating = True
End Sub
Try the next way, please:
Copy the next Subs in a standard module and run the first one. It will assign a specific macro to all check boxes from column A:A:
Sub AssingMacro()
Dim sh As Worksheet, s As Shape, chkB As CheckBox
Set sh = ActiveSheet
For Each s In sh.Shapes
If left(s.Name, 6) = "Check " And s.TopLeftCell.Column = 1 Then
s.OnAction = "CheckBoxesHeaven"
End If
Next
End Sub
Sub CheckBoxesHeaven()
Dim sh As Worksheet, chB As CheckBox
Set sh = ActiveSheet
Set chB = sh.CheckBoxes(Application.Caller)
If chB.Value = 1 Then
Debug.Print chB.TopLeftCell.Offset(0, 2).Value
If chB.TopLeftCell.Offset(0, 2).Value = "18-49" Then
sh.Range("C3").Value = sh.Range("C3").Value + 1
ElseIf chB.TopLeftCell.Offset(0, 2).Value = "50-64" Then
sh.Range("C1").Value = sh.Range("C1").Value + 1
Else
sh.Range("C2").Value = sh.Range("C2").Value + 1
End If
Else
If chB.TopLeftCell.Offset(0, 2).Value = "18-49" Then
sh.Range("C3").Value = sh.Range("C3").Value - 1
ElseIf chB.TopLeftCell.Offset(0, 2).Value = "50-64" Then
sh.Range("C1").Value = sh.Range("C1").Value - 1
Else
sh.Range("C2").Value = sh.Range("C2").Value - 1
End If
End If
End Sub
Assort the values in range "C1:C3" to match the appropriate check boxes value. In order to automatically do that, please use the next code:
Sub ResetCheckBoxesValues()
Dim sh As Worksheet, chkB As CheckBox, i As Long
Dim V50_64 As Long, V18_49 As Long, VLess18 As Long
Set sh = ActiveSheet
For Each chkB In sh.CheckBoxes
If chkB.TopLeftCell.Column = 1 Then
Select Case chkB.TopLeftCell.Offset(0, 2).Value
Case "50-64"
If chkB.Value = 1 Then V50_64 = V50_64 + 1
Case "18-49":
If chkB.Value = 1 Then V18_49 = V18_49 + 1
Case "<18":
If chkB.Value = 1 Then VLess18 = VLess18 + 1
End Select
End If
Next
sh.Range("C1:C3").Value = Application.Transpose(Array(V50_64, VLess18, V18_49))
End Sub
Start playing with check boxes selection. It will add a unit to the appropriate cell if checking and decrease it with a unit in case of unchecking.
Please, test it and send some feedback
It will not be "very" dynamic, make sure to click on a random Excel cell, to make the formula recalculate after updating the check on the checkbox.
But the formula works in Excel, with the checkboxes you have created:
Public Function CountCheckBoxes()
Dim chkBox As Shape
Dim counter As Long
With ThisWorkbook.Worksheets(1)
For Each chkBox In .Shapes
If InStr(1, chkBox.Name, "Check Box") Then
If .Shapes(chkBox.Name).OLEFormat.Object.Value = 1 Then
counter = counter + 1
End If
End If
Next chkBox
End With
CountCheckBoxes = counter
End Function
Probably you should think about a suitable workaround to avoid ThisWorkbook.Worksheets(1), depending on where the code is residing.

Create ActiveX checkbox in specific cell

In my Sheet 1, Column A has some values and I need to create a Active X checkbox for all the values in Sheet 2 in a specific cell. First I need to check whether Active X checkbox is there for the value or not, If its not there, I need to create. I already tried the below code, But its creating the duplicate checkboxes.
Sub Addcheckbox()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=183, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
rr = rr + 1
Next cell
End Sub
How to check whether ActiveX checkbox already present in the sheet or not with Caption name
i tried this code for checking the checkboxes.. But its not working..
Function shapeExists(ByRef shapename As String) As Boolean
shapeExists = False
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.name = shapename Then
shapeExists = True
Exit Function
End If
Next sh
End Function
ActiveX Checkboxes are OleObjects. Is this what you are trying?
Also you need to specify the correct .Top else they will be created at the same place. See how I used Top:=cell.Top
Sub Sample()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
If Not CBExists(cell.Value) Then '<~~ Check if the checkbox exists
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=cell.Top, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
End If
rr = rr + 1
Next cell
End Sub
'~~> Function to check if the checkbox exists
Function CBExists(s As String) As Boolean
Dim oleObj As OLEObject
Dim i As Long
For i = 1 To Worksheets("Sheet1").OLEObjects.Count
If s = Worksheets("Sheet1").OLEObjects(i).Object.Caption Then
CBExists = True
Exit Function
End If
Next i
End Function

Resources