I'm trying to make a macro which checks a cell for changes. If the cell changes a user has to provide a date. When cancel is pressed or the field is left blank, another cell should be cleared. When cancel is pressed the cell gets cleared, but when 'ok' is pressed without providing a date I get an error. My code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myValue As Date
If Target.Address = "$E$17" Then
myValue = Application.InputBox("Geef de revisiedatum op, DD/MM/JJ", "Revisie datum")
Range("$I$17").Value = myValue
If myValue = False Then
Range("$I$17") = ""
Exit Sub
End If
End If
If Target.Address = "$E$20" Then
myValue = Application.InputBox("Geef de revisiedatum op, DD/MM/JJ", "Revisie datum")
Range("$I$20").Value = myValue
If myValue = False Then
Range("$I$20") = ""
Exit Sub
End If
End If
End Sub
This is because you have myvalue declared as a date. When no value is returned it is a string that a date can't handle.
Change myValue to a string. Then your checks for myValue = False will change to If myValue = "" then.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myValue As String
If Target.Address = "$E$17" Then
myValue = Application.InputBox("Geef de revisiedatum op, DD/MM/JJ", "Revisie datum")
Range("$I$17").Value = myValue
If myValue = "" Then
Range("$I$17") = ""
Exit Sub
End If
End If
If Target.Address = "$E$20" Then
myValue = Application.InputBox("Geef de revisiedatum op, DD/MM/JJ", "Revisie datum")
Range("$I$20").Value = myValue
If myValue = "" Then
Range("$I$20") = ""
Exit Sub
End If
End If
End Sub
Related
My worksheet is set up with data validation dropdowns and I am wanting a macro to ONLY trigger when the value of the cell is changed from another value in the dropdown, not from the default "empty" value.
Here is what I am trying to use:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Then
If IsEmpty(Target.Value) = True Then
MsgBox "Test1"
Else
MsgBox "Test2"
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
My problem is that this "IsEmpty" command is reading the cell AFTER the selection not before. I want it to read what the cells value was BEFORE the selection not after.
How can I do this?
Example approach:
Const COL_CHECK As Long = 5
Private oldVal
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Set c = Target.Cells(1) '<< in case multiple cells are changed...
If c.Column = COL_CHECK Then
If oldVal <> "" Then
Debug.Print "changed from non-blank"
Else
Debug.Print "changed from blank"
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
Set c = Target.Cells(1)
oldVal = IIf(c.Column = COL_CHECK, c.Value, "")
Debug.Print "oldVal=" & oldVal
End Sub
Another approach:
This will need one cell per validation-dropdown:
Function ValChange(Cell2Follow As Range) As String
ValChange = ""
If Len(Application.Caller.Text) = 0 Then Exit Function
If Application.Caller.Text = Cell2Follow.Text Then Exit Function
MsgBox "value of the cell is changed from another value in the dropdown" & vbLf & "not from the default 'empty' value"
End Function
in a different cell, assumed the dropdown is in E6:
=E6&ValChange(E6)
application.caller.text will be the old value
(calculation must be automatic)
I am puuting a check mark on double click on certain cells. My code looks like this :
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("AA38:AK48,M32:M40,M42:M52,M54:M69")) Is Nothing Then
Cancel = True
If VarType(Target.Value) = vbBoolean Then
Target.Value = Not (Target.Value)
Else
Target.Value = IIf(Target.Value = "ü", Null, "ü")
End If
End If
End Sub
But on the Merged cellls AA-AK it gives me an error
Try it like this...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("AA38:AK48,M32:M40,M42:M52,M54:M69")) Is Nothing Then
Cancel = True
If VarType(Target.Cells(1).Value) = vbBoolean Then
Target.Cells(1).Value = Not (Target.Cells(1).Value)
Else
Target.Cells(1).Value = IIf(Target.Cells(1).Value = "ü", Null, "ü")
End If
End If
End Sub
I am running two VBA formulas.
The first hides all cells with empty information the first column.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A49")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A47")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The second Formula strings data together and placeses this information in the next cell that is empty (aka the first hidden cell) when the button is clicked.
Option Explicit
Dim iwsh As Worksheet
Dim owsh As Worksheet
Dim output As String
Dim i As Integer
Sub Copy()
Set iwsh = Worksheets("Budget")
Set owsh = Worksheets("Release Burnup")
i = 3
While owsh.Cells(i, 1) <> ""
i = i + 1
Wend
output = "R" & iwsh.Cells(13, 2).Value & "-S" & iwsh.Cells(14, 2).Value
owsh.Cells(i, 1) = output
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End Sub
Previously, this has been causing no problem... Something has happened that is causing the workbook to crash anytime I try to delete information out of one of the cells with the new data.
PS: This is the list of my other formulas. maybe there is something in these that is interacting with the formentioned code?
Private Sub NewMemberBut_Click()
'causes userform to appear
NewMember.Show
'reformats button because button kept changing size and font
NewMemberBut.AutoSize = False
NewMemberBut.AutoSize = True
NewMemberBut.Height = 40.25
NewMemberBut.Left = 303.75
NewMemberBut.Width = 150
End Sub
'Similar code to the problematic code in question, but this one works fine
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A35,A41:A80")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A35,A41:A80")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
'Code for UserForm
Option Explicit
Dim mName As String
Dim cName As String
Dim mRole As String
Dim cRole As String
Dim i As Integer
Dim x As Integer
Dim Perc As Integer
Dim Vac As Integer
Dim Prj As Worksheet
Dim Bud As Worksheet
Private Sub NewMember_Initialize()
txtName.Value = ""
cboRoleList.Clear
Scrum.Value = False
txtPercent.Value = ""
txtVacation.Value = ""
txtName.SetFocus
End Sub
Private Sub AddMember_Click()
If Me.txtName.Value = "" Then
MsgBox "Please enter a Member name.", vbExclamation, "New Member"
Me.txtName.SetFocus
Exit Sub
End If
If Me.cboRoleList = "Other" And Me.txtCustomRole = "" Then
MsgBox "Please provide a role name.", vbExclamation, "Other Role"
Exit Sub
End If
If Me.cboRoleList.Value = "" Then
MsgBox "Please select a Role.", vbExclamation, "Member Role"
Me.cboRoleList.SetFocus
Exit Sub
End If
If Me.cboRoleList <> "Other" And Me.txtPercent = "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtPercent.Value > 100 And Me.txtPercent <> "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtVacation.Value = "" Then
Me.txtVacation.Value = 0
End If
Dim i As Long
Set Prj = Worksheets("Project Team")
Set Bud = Worksheets("Budget")
Prj.Activate
i = 5
x = 1
If Me.cboRoleList.Value = "Other" Then
i = 46
End If
While Prj.Cells(i, 1) <> ""
i = i + 1
Wend
If cboRoleList = "Other" Then
Cells(i, x).Value = txtCustomRole.Value
End If
If cboRoleList <> "Other" Then
Cells(i, x).Value = cboRoleList.Value
End If
x = x + 1
Cells(i, x).Value = txtName.Value
x = x + 1
If Me.cboRoleList.Value <> "Other" Then
Cells(i, x).Value = txtPercent.Value
End If
Unload Me
End Sub
Private Sub CloseBut_Click()
Unload Me
End Sub
Change the event driven Worksheet_SelectionChange to Worksheet_Change and isolate further by only processing when something changes in A3:A49.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A49")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim c As Range
For Each c In Intersect(Target, Range("A3:A49"))
c.EntireRow.Hidden = CBool(c.Value = vbNullString)
Next c
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Caveat: A Worksheet_Change is not triggered on the change in a cell from the cell's formula. Only by typing, deleting or dragging a cell's contents. Adding or removing a formula will trigger it but not when a formula's result changes from another value somewhere in the workbook changing. This should not affect you as no formula can return vbNullString but it is worth mentioning for others.
I have the below code that will throw a prompt when a particular sheet is empty before saving the workbook.
Purpose of code: To check, if value of drop-down is "yes" in Main Sheet and if "yes", check if given range on a particular sheet is blank. If "yes", throw a prompt and change the drop down value to "No" on main sheet.
Concern: For loop in the code will check if any cell is empty in given range, instead, I want a code to check if there is an entry in any one cell in given range. Lets say given range is E10:G19, if we have an entry in E10, It should come out of the code and should not throw a prompt and should throw only if all the cells in given range is empty.
Question: What should replace my For loop that can serve my purpose?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim Rvalue As Range
Dim cell As Range
Set Rvalue = Sheets("Uni-corp").Range("E10:G19")
If Worksheets("Main").Range("E29").Value = "YES" Then
For Each cell In Rvalue
If IsEmpty(cell) Then
bOk = True
Exit For
Else: bOk = False
End If
Next
If bOk Then
If MsgBox("Sheet is blank", vbOKCancel + vbInformation) = vbOK Then
Worksheets("Main").Range("E29").Value = "NO"
Cancel = True
End If
End If
End If
End Sub
Here you go:
Option Explicit
Public Function b_is_range_empty(my_rng As Range)
If Application.WorksheetFunction.CountA(my_rng) > 0 Then
b_is_range_empty = False
Else
b_is_range_empty = True
End If
End Function
Public Sub TestMe()
Debug.Print b_is_range_empty(Selection)
End Sub
The idea is to use the built-in formula in Excel - CountA. It is optimized for faster search. In the test it works with selection of the area.
Edit:
In stead of this:
For Each cell In Rvalue
If IsEmpty(cell) Then
bOk = True
Exit For
Else: bOk = False
End If
Next
Write simply this:
bOK = b_is_range_empty(Rvalue)
Maybe you're after something like this:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If UCase(Worksheets("Main").Range("E29").Value) <> "YES" Then Exit Sub
If WorksheetFunction.CountA(Worksheets("Uni-corp").Range("E10:G19")) > 0 Then Exit Sub
If MsgBox("Sheet is blank", vbOKCancel + vbInformation) = vbOK Then
Worksheets("Main").Range("E29").Value = "NO"
Cancel = True '<--| this will make the macro not save the workbook
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim Rvalue As Range
Dim cell As Range
Set Rvalue = Sheets("Uni-corp").Range("E10:G19")
If Worksheets("Main").Range("E29").Value = "YES" Then
For Each cell In Rvalue
If IsEmpty(cell)<>true Then
bOk = false
Exit For
Else: bOk = true
End If
Next
If bOk Then
If MsgBox("Sheet is blank", vbOKCancel + vbInformation) = vbOK Then
Worksheets("Main").Range("E29").Value = "NO"
Cancel = True
End If
End If
If bOk=false Then
If MsgBox("Sheet is not blank", vbOKCancel + vbInformation) = vbOK Then
Worksheets("Main").Range("E29").Value = "Yes"
Cancel = True
End If
End If
End If
End Sub
You appear to be exiting your for loop when the first cell is empty, you will want it to only exit when it finds a value instead:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim Rvalue As Range
Dim cell As Range
Set Rvalue = Sheets("Uni-corp").Range("E10:G19")
If Worksheets("Main").Range("E29").Value = "YES" Then
For Each cell In Rvalue
If IsEmpty(cell) Then
bOk = True
'Exit For moved to Else section
Else: bOk = False
Exit for
End If
Next
If bOk Then
If MsgBox("Sheet is blank", vbOKCancel + vbInformation) = vbOK Then
Worksheets("Main").Range("E29").Value = "NO"
Cancel = True
End If
End If
End If
End Sub
This is a newb question:
I have two sheets. Sheet 1 is where there is a form to enter data. When you double click on any cell in column A, a user form pop up comes up. You enter a few keys from any entry that is in the A column of sheet 2 and it autocompletes.
The problem I am having is: I only want to enter data on a specific cell, for instance A1 .. not the whole column of A. A second thing I wanted was that instead of a double click, I wanted it to work with a single click. Can anyone please help.
Here is the VBA code for Sheet 1 where you enter the data
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim uiChosen As String
Dim MyList As Range
Dim myPrompt As String
If Target.Column <> 1 Then Exit Sub
Set MyList = Sheet2.Range("Cariler")
myPrompt = "Lütfen Bir Cari Seçin"
uiChosen = UserForm1.ChooseFromList(MyList, myPrompt, Default:=Target.Value, xlFilterStyle:=xlContains)
If StrPtr(uiChosen) <> 0 Then
Target.Value = uiChosen
Cancel = True
End If
End Sub
Here is the code for the user form:
Option Explicit
' in userform's code module
Dim FullList As Variant
Dim FilterStyle As XlContainsOperator
Dim DisableMyEvents As Boolean
Dim AbortOne As Boolean
Const xlNoFilter As Long = xlNone
Private Sub butCancel_Click()
Unload Me
End Sub
Private Sub butOK_Click()
Me.Tag = "OK"
Me.Hide
End Sub
Private Sub ComboBox1_Change()
Dim oneItem As Variant
Dim FilteredItems() As String
Dim NotFlag As Boolean
Dim Pointer As Long, i As Long
If DisableMyEvents Then Exit Sub
If AbortOne Then AbortOne = False: Exit Sub
If TypeName(FullList) Like "*()" Then
ReDim FilteredItems(1 To UBound(FullList))
DisableMyEvents = True
Pointer = 0
With Me.ComboBox1
Select Case FilterStyle
Case xlBeginsWith: .Tag = LCase(.Text) & "*"
Case xlContains: .Tag = "*" & LCase(.Text) & "*"
Case xlDoesNotContain: .Tag = "*" & LCase(.Text) & "*": NotFlag = True
Case xlEndsWith: .Tag = "*" & LCase(.Text)
Case xlNoFilter: .Tag = "*"
End Select
For Each oneItem In FullList
If (LCase(oneItem) Like .Tag) Xor NotFlag Then
Pointer = Pointer + 1
FilteredItems(Pointer) = oneItem
End If
Next oneItem
.List = FilteredItems
.DropDown
DisableMyEvents = False
If Pointer = 1 Then .ListIndex = 0
End With
End If
End Sub
Private Sub ComboBox1_Click()
butOK.SetFocus
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case vbKeyReturn: Call butOK_Click
Case vbKeyUp, vbKeyDown: AbortOne = True
End Select
End Sub
Private Sub Label1_Click()
End Sub
Private Sub UserForm_Activate()
ComboBox1.SetFocus
If ComboBox1.Text <> vbNullString Then
Call ComboBox1_Change
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox1.MatchEntry = fmMatchEntryNone
End Sub
Public Function ChooseFromList(ListSource As Variant, Optional Prompt As String = "Choose one item", _
Optional Title As String = "Cari Arama Programı", Optional Default As String, _
Optional xlFilterStyle As XlContainsOperator = xlBeginsWith) As String
Dim Pointer As Long, oneItem As Variant
If TypeName(ListSource) = "Range" Then
With ListSource
Set ListSource = Application.Intersect(.Cells, .Parent.UsedRange)
End With
If ListSource Is Nothing Then Exit Function
If ListSource.Cells.Count = 1 Then
ReDim FullList(1 To 1): FullList(1) = ListSource.Value
ElseIf ListSource.Rows.Count = 1 Then
FullList = Application.Transpose(Application.Transpose(ListSource))
Else
FullList = Application.Transpose(ListSource)
End If
ElseIf TypeName(ListSource) Like "*()" Then
ReDim FullList(1 To 1)
For Each oneItem In ListSource
Pointer = Pointer + 1
If UBound(FullList) < Pointer Then ReDim Preserve FullList(1 To 2 * Pointer)
FullList(Pointer) = oneItem
Next oneItem
ReDim Preserve FullList(1 To Pointer)
ElseIf Not IsObject(ListSource) Then
ReDim FullList(1 To 1)
FullList(1) = CStr(ListSource)
Else
Err.Raise 1004
End If
Me.Caption = Title
Label1.Caption = Prompt
FilterStyle = xlFilterStyle
DisableMyEvents = True
ComboBox1.Text = Default
ComboBox1.List = FullList
DisableMyEvents = False
butOK.SetFocus
Me.Show
With UserForm1
If .Tag = "OK" Then ChooseFromList = .ComboBox1.Text
End With
End Function
There is no single click event. Use Intersect to test wherther or not the target cell is within a given range.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1")) Is Nothing Then
Dim uiChosen As String
Dim MyList As Range
Dim myPrompt As String
If Target.Column <> 1 Then Exit Sub
Set MyList = Sheet2.Range("Cariler")
myPrompt = "Lütfen Bir Cari Seçin"
uiChosen = UserForm1.ChooseFromList(MyList, myPrompt, Default:=Target.Value, xlFilterStyle:=xlContains)
If StrPtr(uiChosen) <> 0 Then
Target.Value = uiChosen
Cancel = True
End If
End If
End Sub