I'm trying to make my shape change height automatically, based on what is in a cell, when that cell value is changed.
The tricky part is that it would be 1" of height per every 1000 inputted into that cell.
I thought it would be something like the below, but that's based on ranges and doesn't take the ratio into consideration and is pretty tedious.
Private Sub Worksheet_ShapeHeight()
If Range("C8").Value >= 1000 And Range("").Value <= 2000 Then
Shapes("Rectangle 1").Height = 1
Else
If Range("C8").Value >= 2000 And Range("").Value <= 3000 Then
Shapes("Rectangle 1").Height = 2
'---And so on..
End Sub
Screenshot of Sheet1
Perhaps something like the following. Note that the unit for Shape.Height is points, not inches.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("C8")) Is Nothing Then Exit Sub
Dim calcHeight As Single
calcHeight = Int(Me.Range("C8").Value / 1000) * 72 ' 72 points per inch
Me.Shapes("Rectangle 1").Height = calcHeight
End Sub
Related
I'm making a form to calculate the price rooms we rent out. Among others this cost is based on the arrival and departure date. You can see a screenshot of the form below;
- "Aankomst" (the first date) means "Arrival"
- "Vertrek" (the second date) means "Departure"
As you can see, I added buttons to respectively decrease or increase the dates. I also made sure that impossible values would be rectified. The departure date can never be equal or lower than the arrival date. When trying to decrease the departure date, or increase the arrival date, this is triggered when wrong.
When inputting values manually, this check does not occur. A bit of searching learned me I could do this with a change event macro.
I wrote this bit of code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = "$B$5" And Range("$b$5").Value + 1 >= Range("$b$6").Value Then
Range("$b$6").Value = Range("$b$5").Value + 1
End If
If Target.Address = "$B$6" And Range("$b$6").Value - 1 <= Range("$b$5").Value Then
Range("$b$5").Value = Range("$b$6").Value - 1
End If
Application.ScreenUpdating = True
End Sub
B5 is the cell containing the arrival date, b6 is the cell containing the departure date. When triggered, this macro should check both which cell was changed (b5 or b6) and if the arr. date is equal to or higher than the dep. date. And if so, automatically change the other cell (the one that was not manually changed).
Now when I omit the second if-statement, it works just fine. If I omit the second if-statement, it works fine as well. When both statements are active, it bugs everytime. I get a prompt saying 'insufficient stacking space' (translated from dutch).
I've tried this code as well, using case:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Range("b6").Value - 1 <= Range("b5").Value Then
Select Case Target.Address(0, 0)
Case "b5": Range("vertrek").Value = Range("aankomst").Value + 1
Case "b6": Range("aankomst").Value = Range("vertrek").Value - 1
End Select
End If
Application.ScreenUpdating = True
End Sub
...but also without success, same error. When I debug, I can see that the date was indeed changed if necessary, so I presume I somehow create an infinite loop or smth and that causes Excel to bug.
Does anyone know where my error lies or anyone aware of another method to achieve my goal?
Protect against re-raising the same event over and over:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Address = "$B$5" And Range("$b$5").Value + 1 >= Range("$b$6").Value Then
Range("$b$6").Value = Range("$b$5").Value + 1
End If
If Target.Address = "$B$6" And Range("$b$6").Value - 1 <= Range("$b$5").Value Then
Range("$b$5").Value = Range("$b$6").Value - 1
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I've got several data validation dropdown boxes across the top row of a spreadsheet. I'm using the following code to expand the box size (to help the users see their options) upon selecting the cell. I'm having problems getting the VBA script to ignore columns A:C upon returning the columns to normal width. These columns should be fixed at 20 and the others returned to 8.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("D1:AP1")) Is Nothing And Target.Columns <> "A1:C1" Then
ActiveWindow.Zoom = 100
Target.Columns.ColumnWidth = 8
Else
ActiveWindow.Zoom = 120
Target.Columns.ColumnWidth = 30
End If
End Sub
If I have understand well, the code shall be like:
Application.ScreenUpdating = False
If Target.Cells.Count > 1 Then
Exit Sub
Application.ScreenUpdating = True
End If
Set xx = Application.Intersect(Target, Range("D1:AP1"))
If xx Is Nothing Then
ActiveWindow.Zoom = 100
For i = 4 To 42
If Columns(i).Hidden = False Then Columns(i).ColumnWidth = 8
Next
Else
ActiveWindow.Zoom = 120
Target.Columns.ColumnWidth = 30
End If
Application.ScreenUpdating = True
The control of the Target cor Columns A:C shall be made after.
Also I prefer to chaneg all the width for columns D:AP when you return ...
I have a little bit chaged the code... Adding the check if are Hidden, and with the line Application.ScreenUpdating, the code show only at the end.
I have also removed code non necessary (some if ...).
Take as example the following code which should state whether the content of Cell A3 is greater or smaller than 0.25, where in Cell A3 we have a formula like RAND() whoch generates random numbers between 0 and 1.
Private Sub Worksheet_Change(ByVal Target As Range)
Calculate
If Range("A3") > 0.25 Then
Range("B3") = "greater than 0.25"
Else: Range("B3") = "smaller than 0.25"
End If
End Sub
How to make this Event conditions to be verified in continuous time?
What about using timer? this function calls each 1 second
Sub Test()
Calculate
If Range("A3") > 0.25 Then
Range("B3") = "greater than 0.25"
Else
Range("B3") = "smaller than 0.25"
End If
Application.OnTime Now + TimeSerial(0, 0, 1), "Test"
End Sub
I think there is no option for that. Have been looking for it myself. There is no change event for calculated cells. The only option is to check dependencies of a calculated field but in this case there are none.
Ok I have a worksheet "Goal 0" that with some ranges, make some calculations like...
(in A1)
=SUM(G2:G68)*I17
Then if I add/modify any of the values in 62-G68, the cell is auto calculated (numbers that are mainly negative and some possitive).
The objetive is: According to the sum of the range, find the value of I17 where the result of A1 is equal or more than 0. (Starting from 0, incrementing it 1 by 1, decimals not needed)
Manually I can add change i17 untill it reaches the goal. How ever I want to make it automatically, so if a value in the range of G2 to G68 changes it recalculate the value of I17, untill (A1 calculation gets value equal or higher than 0) but if already is higger or equal than 0 then do nothing.
Hope I explain it well
EDIT: Now I created this code ...
Function IncreaseTheValue()
If Range("A1") < 0 Then
Range("I17").Value = 0
Do While Range("A1").Value < 0
Range("I17").Value = Range("I17").Value + 1
Loop
End If
End Function
And works perfect, how ever it does not fires when I make a chage. How do I do that...
I try adding this in A2 cell but did not worked ...
=IF(A1 < 0, IncreaseTheValue(), "")
Regards
You shouldn't really be doing this as a Function; it is inadequate as you notice, but also not appropriate use of a Function where a Sub or event handler is more appropriate.
Based on your requirements, put the code in the Worksheet_Change event handler. You will need to fine-tune it so that it only fires when a change is made in the range G2:G68.
Try this (untested):
Private Sub Worksheet_Change(ByVal Target as Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("G2:G68")) Is Nothing Then
If Range("A1") < 0 Then
Range("I17").Value = 0
Do While Range("A1").Value < 0
Range("I17").Value = Range("I17").Value + 1
Loop
End If
End If
Application.EnableEvents = True
End Sub
Updated per pnuts comments. This method below will trigger the macro any time any cell changes -- this might be overkill, or it might be necessary if G2:G68 is formulas which change based on changes to other cells. Either method can be fine-tuned to better suit your exact needs.
Private Sub Worksheet_Change(ByVal Target as Range)
Application.EnableEvents = False
If Range("A1") < 0 Then
Range("I17").Value = 0
Do While Range("A1").Value < 0
Range("I17").Value = Range("I17").Value + 1
Loop
End If
Application.EnableEvents = True
End Sub
Im having a little trouble with a code in excel vba.
What I want to do is that If any CELL within a RANGE on Sheet 1 is <= 2000 THEN hide a given row on Sheet 2. So it only takes 1 cell within a that range to be <= 2000 for the rows on the other sheet to be hidden. Kind of like a rotten apple spoils the bunch kind of thing.
Any help would be greatly appriciated. Thanks in Advance.
Edit: code i have that isnt working:
Edit2: code updated based on comments given, still no luck with it working.
Private Sub HideRows()
Sheets("Summary").Cells.EntireRow.Hidden = False
For Each cell In Sheets("Worksheet").Range("G9:P9")
If Abs(cell.Value) < 2000 Then
Sheets("Summary").Rows(11).EntireRow.Hidden = True
Sheets("Summary").Rows(23).EntireRow.Hidden = True
Sheets("Summary").Rows(43).EntireRow.Hidden = True
Sheets("Summary").Rows(54).EntireRow.Hidden = True
Sheets("Summary").Rows(78).EntireRow.Hidden = True
Sheets("Summary").Rows(90).EntireRow.Hidden = True
End If
Next
End Sub
The code does have the correct enders too such as End Select, Next, End Sub
-Matt
I'd do it this way:
Private Sub HideRows()
Worksheets("Summary").Cells.EntireRow.Hidden = False
For Each cell In Sheets("Worksheet").Range("G9:P9")
If Abs(cell) < 2000 Then
Worksheets("Summary").Range("A11,A22,A43,A54,A78,A90").EntireRow.Hidden = True
End If
Next
End Sub
It's best to use the Range object and reference non-contiguous cells as it makes it a single line.
You might Want to try and avoid Loops Something Like:
Sub NoLoopSample()
Dim lngLessThenSum As Long, lngGreaterThenSum As Long
Dim rngTestRange As Range
Set rngTestRange = Sheets("Worksheet").Range("G9:P9")
lngBetween2k4k = WorksheetFunction.SumIfs(rngTestRange, rngTestRange, ">=" & 2000, rngTestRange, "<" & 4000)
lngLessThenSum = WorksheetFunction.SumIf(rngTestRange, "<" & 2000)
If lngBetween2k4k > 0 Then
MsgBox "Atleast 1 Number Is Between 2000 And 4000"
End If
If lngLessThenSum > 0 Then
MsgBox "Atleast 1 Number Is Less then 2000"
Sheets("Summary").Range("11:11, 23:23, 43:43, 54:54, 78:78, 90:90").EntireRow.Hidden = True
End If
End Sub
Should do what you want and won't have to test EVERY Single cell in your range. There may be other functions or ways to do it but this was at the top of my head. Although on such a small range you shouldn't even notice the difference.
I also like to make as few changes to a worksheet from VBA as possible so in my example I hide all the rows you mention in one call rather then a call for each row.
Maybe it's about EntireRow property ..
Reference .. http://msdn.microsoft.com/en-us/library/office/ff836836.aspx
Since your code .. Rows("11").EntireRow.Hidden = True .. you have to make it sure that Row("11") is Range var ..
And to hide rows you may do Rows(11).Hidden = True
Sub try()
i = 1
While Sheet1.Cells(i, 1).Value <> ""
If Sheet1.Cells(i, 1).Value > 2000 Then
Sheet2.Rows(i).EntireRow.Hidden = True
End If
i = i + 1
Wend
End Sub
Straight to the point:
Range("a11,a22,a43,a54,a78,a90").EntireRow.Hidden = [sum((g9:p9>0)*(g9:p9<2001))]
You are concerned more with the minimum value only. I would rather use Excel's Min function for the work:
Sub HideRows()
Set InRng = Worksheets("Worksheet").Range("G9:P9") 'Input Range
Set OutRng = Worksheets("Summary").Range("A11,A22,A43,A54,A78,A90") 'Rows to be hidden
MinVal = Application.WorksheetFunction.Min(InRng) 'Invoking inbuilt function to get minimum value
If MinVal < 2000 Then
OutRng.EntireRow.Hidden = True
End If
End Sub