I have a worksheet change event.
Original Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("J12") < Range("G12") Then
MsgBox "Oppps. Your system is not working!"
End If
End Sub
I am trying to expand upon the code to:
a. Increase the range from single cells (J12 and G12) to an extended cell range (J12:42, G12:42).
b. Instead of having the change event triggered by less than (J12 < G12), have it triggered by a % difference between J12 < G12.
Here is the updated code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim diffPercent
'Check that the data is changed between row 12 and 42 and it is even row. eg 12,14,16...42.
If (Target.Row > 10 And Target.Row < 44) And ((Target.Row Mod 2) = 0) Then 'And _
'(Target.Column = 7 Or Target.Column = 10) Then
'Get the values in J ang G columns of that particular row.
number1 = Range("G" & Target.Row).Value
number2 = Range("J" & Target.Row).Value
'Check for presence of both the inputs to calculate difference in percentage.
If Not chkInputs(number1, number2) Then
Exit Sub
End If
'Calculate the percentage difference.
diff = number2 - number1
diffPercent = (diff / number2) * 100
'Give alert if difference more than 10 percent
If diffPercent > 10 Then
MsgBox "Oppps. Your system is not working! The difference is :" & diff & "|" & diffPercent
End If
End If
End Sub
Function chkInputs(number1, number2)
chkInputs = False
If IsNumeric(number1) And IsNumeric(number2) Then
chkInputs = True
End If
End Function
Related
My code resizes an image. If the image's TopLeftCell is $A$1, it will work. However, if it is any other cell the width or height ends up being 0.
It is supposed to be running through two functions: getCellHeight and getCellWidth to grab the total height and width of merged cells, but it will also work with non-merged cells as long as the TopLeftCell is $A$1.
When working with non-merged cells:
Anything $A$n where n is greater than 1 results in a width with 0
height.
Anything $(n)$1 where n is greater than A results in a height with 0
width.
Anything $(n)$(m) where n is greater than A and m is greater than 1
results in 0 height and 0 width.
When working with merged cells:
The functionality is similar to non-merged cells, the difference being that on $(n)$(m) it will only run the height and width for loops if:
The number of rows merged is >= 9. At 9 rows, the for loop for
counting rows will run a single time.
The number of columns merged is >= 7. At 7 columns, the for loop for
counting columns will run a single time.
Anything below 9 rows results in 0 height, anything below 7 rows
results in 0 width.
Here is the code:
Sub TestCode()
If TypeOf Selection Is Picture Then
Call ResizeSingleImage(Selection)
ElseIf TypeOf Selection Is DrawingObjects Then
Call ResizeMultipleImages(Selection)
ElseIf TypeOf Selection Is Range Then
MsgBox ("Please make sure an image is selected.")
Exit Sub
End If
End Sub
Function ResizeMultipleImages(ByRef refPictures)
For Each refPic In refPictures
Call ResizeSingleImage(refPic)
Next
End Function
Function ResizeSingleImage(ByRef refPicture)
refPicture.ShapeRange.LockAspectRatio = msoTrue
MsgBox ("TopLeftCell: " & refPicture.TopLeftCell.Address)
tempWidth = getCellWidth(refPicture.TopLeftCell)
tempHeight = getCellHeight(refPicture.TopLeftCell)
MsgBox ("Width and Height: " & tempWidth & " " & tempHeight)
If tempWidth > tempHeight Then
refPicture.Height = tempHeight
Else
refPicture.Width = tempWidth
End If
End Function
Function getCellHeight(ByRef cellRef As Range) As Single
curColumn = cellRef.Column
curRow = cellRef.Row
numOfRows = cellRef.MergeArea.Rows.Count
totalHeight = 0
MsgBox (cellRef.Address & " Rows: " & numOfRows)
MsgBox ("Cell Height: " & cellRef.Height)
For cRow = curRow To numOfRows
MsgBox ("In Row For Loop")
totalHeight = totalHeight + Cells(curColumn, cRow).Height
Next
getCellHeight = totalHeight
End Function
Function getCellWidth(ByRef cellRef As Range) As Single
MsgBox (cellRef.Address)
curColumn = cellRef.Column
curRow = cellRef.Row
numOfColumns = cellRef.MergeArea.Columns.Count
totalWidth = 0
For col = curColumn To numOfColumns
MsgBox ("In Column For Loop")
totalWidth = totalWidth + Cells(curRow, col).Width
Next
MsgBox (cellRef.Address & " Columns: " & numOfColumns)
getCellWidth = totalWidth
End Function
Tested:
Sub Tester()
ResizeSingleImage ActiveSheet.Shapes(1)
End Sub
Sub ResizeSingleImage(ByRef refPicture)
Dim rng As Range, tempWidth, tempHeight
Set rng = refPicture.TopLeftCell.MergeArea
refPicture.Top = rng.Top
refPicture.Left = rng.Left
tempWidth = rng.Width
tempHeight = rng.Height
refPicture.LockAspectRatio = msoTrue
'which dimension to resize?
If tempWidth / refPicture.Width > tempHeight / refPicture.Height Then
refPicture.Height = tempHeight
Else
refPicture.Width = tempWidth
End If
End Sub
The problem with your original looping: let's say cellRef is A5
Function getCellHeight(ByRef cellRef As Range) As Single
curColumn = cellRef.Column
curRow = cellRef.Row '<< for A5 curRow = 5
numOfRows = cellRef.MergeArea.Rows.Count '<< let's say 4 rows
totalHeight = 0
MsgBox (cellRef.Address & " Rows: " & numOfRows)
MsgBox ("Cell Height: " & cellRef.Height)
For cRow = curRow To numOfRows '<<<<this loops from 5 to 4....
'code in loop doesn't execute....
MsgBox ("In Row For Loop")
totalHeight = totalHeight + Cells(curColumn, cRow).Height
Next
getCellHeight = totalHeight
End Function
So there are two answers here, the first one is going to be the best solution, thanks to Tim Williams, the second is going to be the solution to the actual problem I was originally facing.
The first (best) solution
Use .MergeArea.Height on the Range object.
It is quite obvious and is the most straightforward solution. I used the looping solution because when I originally looked up how to find the height and width of a merged cell, the loop was what came up through searches and I assumed properties didn't exist.
The second solution using loop
The issue is in the how the For-loop is setup. For cRow = curRow To numOfRows where curRow is the current row, making it so if you are at row 11 and the number of rows merged is only 3, the loop will never run. My solution to this was For cRow = curRow To (curRow + numOfRows - 1). This will get you the same result, but it goes to show why the use of properties is preferred over re-building the wheel.
Skip my rambling narrative by scrolling down to tldr and Question.
I have several rows and columns with values; e.g. A10:G15. In each row, the value of the cell immediately to the right of any cell is dependent on that cell up to the extents of the columns involved. In this manner, the value of a cell immediately to the right of any cell is always numerically larger than the cell or blank if the original cell is blank.
To maintain this dependency, I want to clear any values to the right if I clear the value from a cell within A:F or progressively add a random number to the remaining cells to the right if I input a new value into any cell within A:F.
Sample data. The 7 in the top-left is A10.
A B C D E F G
7 12 15 19 23 27 28
4 6 10 14 17 18 22
8 10 14 18 23 26 31
8 13 15 18 22 25 30
8 13 16 18 19 21 24
0 3 4 9 10 12 16
'similar data in A19:G22 and A26:G30
tldr
▪ If I clear D12, E12:G12 should also be cleared.
▪ If I type a new value into C14 then D14:G14 should each receive a new value which is random but larger than the previous value.
▪ I might want to clear or paste in several values in a column and would expect the routine to deal with each in turn.
▪ I have several of these non-contiguous regions (see Union'ed range in code sample below) and would prefer a DRY coding style.
Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Debug.Print Target.Address(0, 0)
If Not Intersect(Target, Range("A10:F15, A19:F22, A26:F30")) Is Nothing Then
Dim t As Range
For Each t In Intersect(Target, Range("A10:F15, A19:F22, A26:F30"))
If IsEmpty(t) Then
t.Offset(0, 1).ClearContents
ElseIf Not IsNumeric(t) Then
t.ClearContents
Else
If t.Column > 1 Then
If t <= t.Offset(0, -1) Or IsEmpty(t.Offset(0, -1)) Then
t.ClearContents
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
End If
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
End If
End If
Next t
End If
End Sub
Code explanation
This event driven Worksheet_Change deals with each cell that has changed but only modifies the cell directly to the right, not the remaining cells in that row. The job of maintaining the remaining cells is achieved by leaving event triggers active so that when that single cell to the right is modified, the Worksheet_Change triggers an event that calls itself with a new Target.
Question
The above routine seems to run fine and I have yet to destabilize my project environment despite my best/worst efforts. So what's wrong with intentionally running a Worksheet_Change on top of itself if the reiteration cycles can be controlled to a finite result?
I would argue that what is wrong with recursively triggering the change event is that this way Excel can only sustain a pretty tiny call stack. At 80 calls it killed my Excel instance. When I outsourced the recursion I at least got to a little over 1200 calls, of course adding redundancy to some extent:
Option Explicit
Const RANGE_STR As String = "A10:F15, A19:F22, A26:F30"
Private Sub Worksheet_Change(ByVal target As Range)
Application.EnableEvents = False
Dim t As Range
If Not Intersect(target, Range(RANGE_STR)) Is Nothing Then
For Each t In Intersect(target, Range(RANGE_STR))
makeChange t
Next t
End If
Application.EnableEvents = True
End Sub
Sub makeChange(ByVal t As Range)
If Not Intersect(t, Range(RANGE_STR)) Is Nothing Then
If IsEmpty(t) Then
t.Offset(0, 1).ClearContents
makeChange t.Offset(0, 1)
ElseIf Not IsNumeric(t) Then
t.ClearContents
makeChange t
Else
If t.Column > 1 Then
If t <= t.Offset(0, -1) Or IsEmpty(t.Offset(0, -1)) Then
t.ClearContents
makeChange t
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
makeChange t.Offset(0, 1)
End If
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
makeChange t.Offset(0, 1)
End If
End If
End If
End Sub
I don't think you need recursive calls, read by area, by row, into array, change array and write back to sheet:
Const RANGE_STR As String = "A10:F15, A19:F22, A26:F30"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyArr As Variant, TargetR As Long, TargetC As Long, i As Long, ar As Range, myRow As Range
Dim minC As Long, maxC As Long
If Not Intersect(Target, Range(RANGE_STR)) Is Nothing Then
minC = Range(RANGE_STR).Column 'taken form first area
maxC = 1 + Range(RANGE_STR).Columns.Count 'taken form first area
For Each ar In Target.Areas
TargetC = ar.Column
For Each myRow In ar.Rows
TargetR = myRow.Row
MyArr = Range(Cells(TargetR, minC), Cells(TargetR, maxC))
If IsEmpty(MyArr(1, TargetC)) Or Not IsNumeric(MyArr(1, TargetC)) Then
For i = TargetC To UBound(MyArr, 2)
MyArr(1, i) = Empty
Next i
Else
For i = TargetC + 1 To UBound(MyArr, 2)
MyArr(1, i) = MyArr(1, i - 1) + Application.RandBetween(1, 5)
Next i
End If
If Not Intersect(Range(Cells(TargetR, minC), Cells(TargetR, maxC)), Range(RANGE_STR)) Is Nothing Then
Application.EnableEvents = False
Range(Cells(TargetR, minC), Cells(TargetR, maxC)) = MyArr
Application.EnableEvents = True
End If
Next myRow
Next ar
End If
End Sub
I am adding TextBoxes dynamically in a userform and want to make them a date format to ensure correct date entry. I am unable to find any examples.
Here is my code for the userform activation:
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
fltDays = TextBox3.Value If TextBox3.Value = 0 Then Exit Sub
For i = 1 To fltDays
n = i - 1
Dim TextBox As Control
Set theLbl = FloatDayFrm.Controls.add("Forms.Label.1", "lbl_" & i, True)
With theLbl
.Caption = "Day " & i
.Left = 20
.Width = 60
.Top = n * 24 + 100
.Font.Size = 10
End With
Set TextBox = FloatDayFrm.Controls.add("Forms.TextBox.1", "TextBox_" & n, True)
With TextBox
.Top = 100 + (n * 24)
.Left = 90
.Height = 18
.Width = 50
.Name = "txtBox" & i
.Font.Size = 10
.TabIndex = n + 4
.TabStop = True
End With Next i
FloatDayFrm.Height = 150 + fltDays * 24 With btnOK .Top = 102 + fltDays * 24 .TabStop = True .TabIndex = n + 5 End With
With btnCancel .Top = 102 + fltDays * 24 '.TabStop = True .TabIndex = n + 6 End With
End Sub
This is my code for the Command button:
Private Sub btnOK_Click()
n = TextBox3.Value
For j = 1 To n
Set varFloatDay = FloatDayFrm.Controls("txtBox" & j)
Select Case varFloatDay
Case ""
MsgBox "Day " & j & " can't be blank", vbOKOnly, "Incorrect Value"
Exit Sub
Case Is > TextBox2.Value
MsgBox "Date is after end date", vbOKOnly, "Incorrect Value"
Exit Sub
Case Is < TextBox1.Value
MsgBox "Date is BEFORE end date", vbOKOnly, "Incorrect Value"
Exit Sub
End Select
Next j
End Sub
Any help would be appreciated.
You have to convert text to date format. You can use multiple approach.
Add a label beside textbox to display the format user has to specify the date. Parse the text specified by user as per the format. Do validation and conversion as shown in code below.
Use a calendar control instead of textbox as user input.
Have separate textboxes or cells for year, month and day. Do validation and conversion as shown in code below.
If you are sure date is in the specified format as per regional setting. Do validation and conversion as shown in code below.
Try below
Private Sub TestDate()
Dim yr As Integer
Dim mnth As Integer
Dim day As Integer
Dim dt As Date
Dim strDate As String
'''''3rd approach''''''
yr = ActiveSheet.Range("A1")
mnth = ActiveSheet.Range("B1")
day = ActiveSheet.Range("C1")
If IsNumeric(yr) And IsNumeric(mnth) And IsNumeric(day) Then
If yr < 0 Or mnth < 0 Or day < 0 Then
MsgBox "Year, Month and Day must be greater than 0."
Exit Sub
End If
Else
MsgBox "Year, Month and Day must be an integer."
Exit Sub
End If
'convert to Date
dt = DateSerial(yr, mnth, day)
'''''4th approach''''''
'Display a date according to your system's short date format
'i.e. regional settings in control panel
strDate = Format(ActiveSheet.Range("D1"), "Short Date")
If Not IsDate(strDate) Then
MsgBox "Incorrect Date Format"
Exit Sub
End If
dt = CDate(strDate)
End Sub
Any input in a text box is a text string. If you want it to be a date you can use IsDate(TextBox1.Value) to determine if VBA is able to convert the string to a date (which is a number of Double type). VBA will not execute this test 100% correctly, however. For example, it may not recognised 3/2/17 as a date if your regional settings have the date separator as a period. It may convert 3.2.17 to March 2 if your regional settings are mm.dd.yy. While working on your own PC you may be able to control the regional settings. But if your project will be released into the wild it is better to use a calendar control to get a correct date.
I have a large table, sometimes with hundreds of rows.
This table is generated by another application that exports to excel.
One column has the heading "Adjusted Price".
I want all the rows in this column to contain a formula (presently they're all 0's).
I want to automate this process because the table gets regenerated all the time.
This column may not always be in the same place. So I need a macro that can find this column ("Adjusted Price") and then fill all the cells in that column with a formula (with the exception of the first row of course).
Can this be done?
Thanks in advance :)
Your homework is to figure out how to plug it in!
Option Explicit
Sub setAdjustedPrice()
Dim column As Integer
Dim adjustedPriceColumn As String
Dim found As Boolean
Dim rowCount As Long
column = 1
rowCount = 1
Do While Range(FncAlphaCon(column) & rowCount).Value <> "" And found = False
If (Range(FncAlphaCon(column) & rowCount).Value = "Adjusted Price") Then
found = True
adjustedPriceColumn = FncAlphaCon(column)
Else
column = column + 1
End If
Loop
If found = True Then
Do While rowCount < ActiveSheet.UsedRange.Rows.count
rowCount = rowCount + 1
Range(adjustedPriceColumn & rowCount) = "YOUR FORMULA"
Loop
Else
MsgBox ("'Adjusted Price' column not found, cannot continue.")
End If
End Sub
Private Function FncAlphaCon(aNumber As Integer) As String
' Fixed version 27/10/2011
Dim letterArray As String
Dim iterations As Integer
letterArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If aNumber <= 26 Then
FncAlphaCon = (Mid$(letterArray, aNumber, 1))
Else
If aNumber Mod 26 = 0 Then
iterations = Int(aNumber / 26)
FncAlphaCon = (Mid$(letterArray, iterations - 1, 1)) & (Mid$(letterArray, 26, 1))
Else
'we deliberately round down using 'Int' as anything with decimal places is not a full iteration.
iterations = Int(aNumber / 26)
FncAlphaCon = (Mid$(letterArray, iterations, 1)) & (Mid$(letterArray, (aNumber - (26 * iterations)), 1))
End If
End If
End Function
How can I verify a specific format in a textbox? I am scanning a label into a textbox that contains a date which is formatted like:
mm.dd.yyyy.hh.mm.ss
I have tried things that do not work...
If Not Format(TextBox1, "mm.dd.yyyy.hh.mm.ss") Then
MsgBox "Wrong Format"
End If
You can use this simple function to check if is a date
Function checkFormatDate(str As String) As Boolean
Dim Y
Dim M
Dim D
Dim H
Dim I
Dim S
Dim theDate As Date
M = Mid(str, 1, 2)
D = Mid(str, 4, 2)
Y = Mid(str, 7, 4)
H = Mid(str, 12, 2)
I = Mid(str, 15, 2)
S = Mid(str, 18, 2)
theDate = DateSerial(Y, M, D) + TimeSerial(H, I, S)
If IsDate(theDate) Then
checkFormatDate = True
Else
checkFormatDate = False
End If
End Function
This returns TRUE (if is a date) or FALSE (if not)
Just care about the dates like: 02.05.2016.01.10.05 (where mm.dd.yyyy.hh.mm.ss), because, you need to trust that 02 is the month and not the day, as 05 is the day and not the month, always appears somebody with a great idea, and change the values just because.
Edit #2
Heres a better version of the code:
Tester:
Sub testDate()
Dim Check As Boolean
Check = checkFormatDate2(UserForm1.TextBox1.Text)
'the textbox is inside UserForm1
If Check Then
MsgBox "Is a Date"
Else
MsgBox "Not a Date"
End If
End Sub
Function:
Function checkFormatDate2(str As String) As Boolean
Dim ArrayD
Dim i
Dim m
ArrayD = Split(str, ".")
If UBound(ArrayD) <> 5 Then
checkFormatDate2 = False
Exit Function
End If
For i = 0 To 5
Select Case i
Case 0
If CInt(ArrayD(i)) < 1 Or CInt(ArrayD(i)) > 12 Then
checkFormatDate2 = False
Exit Function
End If
Case 1
If CInt(ArrayD(i + 1)) < 1900 Or CInt(ArrayD(i + 1)) > 2050 Then
'set the botton and limit year as you need
checkFormatDate2 = False
Exit Function
End If
Case 2
m = Day(DateSerial(CInt(ArrayD(2)), CInt(ArrayD(0)) + 1, 1) - 1)
'm = the last (num) day of the month
If CInt(ArrayD(i - 1)) < 1 Or CInt(ArrayD(i - 1)) > m Then
checkFormatDate2 = False
Exit Function
End If
Case 3
If CInt(ArrayD(i)) < 1 Or CInt(ArrayD(i)) > 23 Then
checkFormatDate2 = False
Exit Function
End If
Case 4
If CInt(ArrayD(i)) < 1 Or CInt(ArrayD(i)) > 59 Then
checkFormatDate2 = False
Exit Function
End If
Case 5
If CInt(ArrayD(i)) < 1 Or CInt(ArrayD(i)) > 59 Then
checkFormatDate2 = False
Exit Function
End If
Case Else
End Select
Next i
checkFormatDate2 = True
End Function
Use this function to validate if the text inside the TextBox is a date sending the TextBox.Value or TextBox.Text. Thanks MikeD for your advice. This way is better.
Edit #3
As you tell me in the comments you could use the AfterUpdate on the Textbox, like this:
Private Sub TextBox1_AfterUpdate()
Dim a As Boolean
a = checkFormatDate2(Me.TextBox1.Value)
If a Then
MsgBox "is date"
Else
MsgBox "no date"
End If
End Sub
Where the UserForm1 has a TextBox named TextBox1 inside, and the function checkFormatDate2 is in a regular module. In my case I just send a MsgBox saying that is not a date.
Edit #4
The same way you can validate the text inside the TextBox when Exit the UserForm this way:
1) Add a button and set the Cancel Property to TRUE:
2)And inside the code you put this:
Private Sub CommandButton1_Click()
Dim a As Boolean
a = checkFormatDate2(Me.TextBox1.Value)
If a Then
MsgBox "is date"
Else
MsgBox "no date"
End If
End Sub
This way, when you press ESC in the keyboard or press the button CommandButton1 you try to close the UserForm and fire the code inside, and test the text inside the TextBox and you could do whatever you want, as, don't let the user go away, go back to the TextBox after a message saying what is the right format, well whatever you want.
Try :
If textbox1 = Format(TextBox1, "mm.dd.yyyy.hh.mm.ss") Then
TextBox1 does not contain a date format, so you can't apply a Format() function using date/time format codes.
One solution would be to split your string into array elements and examine them one by one, e.g.
Sub Test()
Dim A() As String, Rslt As Boolean
A = Split(Me.TextBox1.Value, ".") ' load dot seperated elements into array
If UBound(A) <> 5 Then
MsgBox "not 6 numbers seperated by (5) dots"
Rslt = False
ElseIf Val(A(0)) < 1 Or Val(A(0)) > 12 Then
MsgBox "1st part not a valid month (01-12)"
Rslt = False
ElseIf Val(A(1)) < 1 Or Val(A(1)) > 31 Then
MsgBox "2nd part not a valid day (01-31)"
Rslt = False
ElseIf Val(A(2)) < 0 Or Val(A(1)) > 99 Then
MsgBox "3rd part not a valid year (00-99)"
Rslt = False
ElseIf Val(A(3)) < 0 Or Val(A(3)) > 23 Then
MsgBox "4th part not a valid hour (00-23)"
Rslt = False
ElseIf Val(A(4)) < 0 Or Val(A(4)) > 59 Then
MsgBox "5th part not a valid minute (00-59)"
Rslt = False
ElseIf Val(A(5)) < 0 Or Val(A(5)) > 59 Then
MsgBox "6th part not a valid second (00-59)"
Rslt = False
End If
If Not Rslt Then
'beat the user
End If
End Sub
This doesn't consider months with 28/29/30/31 days, but that's only 1 or 2 if's further away.