I'm trying to create a MsgBox that automatically pops up with a prompt of "Yes or No" when a cell in a column changes from blank to "News", and to put the answer into the next column.
I will be continuing to add to rows over time so it has to automatically pop up when the cell changes from blank to "news" and input the answer into the newly added cell to the right.
I'm pretty sure I need the For each loop, but honestly I'm a little lost and get a mismatch error during debug at the If Intersect line.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Set myRange = Range("G2:G1000")
If Intersect(myRange, Target) Then
If Range("G2").Value = "News" Then Answer = MsgBox("Good?", vbYesNo)
Answer = ActiveCell.Offset(0, 1) = 1 'not sure if this is right, or is it Range.Offset?
Dim cel As Range
For Each cel In Range("G2:G1000")
If cel.Value = "News" Then Answer = MsgBox("Good?", vbYesNo)
Answer = ActiveCell.Offset(0, 1) = 1 'not sure if this is right, or is it Range.Offset?
Exit For
Next
End If
End Sub
Here you go:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 7 Then
If Target.Count = 1 Then
If LCase$(Target) = "news" Then
Application.EnableEvents = False
Target(, 2) = Array("Yes", "No")(MsgBox("Good?", vbYesNo) - 6)
End If
End If
End If
Application.EnableEvents = True
End Sub
Related
So far, I have an excel sheet that displays information about parts and in column 'H' there is an initial column that when someone puts their initials in that column it indicates that the part is finished. The row with the new initials should go to the bottom of the data. However, before this happens I have already set up a userform, 'UserForm2' in which the user will put in a password. So, if I could get some guidance on how to go about doing that when they press the 'OkayButton', that would be amazing!
Edit: I have tried moving it down with the worksheet change event, but I can't figure out how to get it to work.
Edit2(defunct): I have sort of figured it out; However, the code that I've indicated below I have added is giving me a invalid qualifier error.
Edit3: Some progress! The newly changed code below does what I it to now; However the 'userform2' keeps popping up after it has been copied to the bottom, I'm not entirely sure why and if anyone would happen to know how to fix it and could tell me that would be much appreciated!
Edit4: It works!... For the most part. The error that was in the previous edit is still popping up. Again, the updated code is below.
Userform2:
Private Sub CancelButton_Click()
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Unload Me
End Sub
Private Sub OkayButton_Click()
IniPass = "pass"
If Me.PasswordIn.Value = IniPass Then
Unload Me
Else
MsgBox "Incorrect Password"
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the Cancel button to close the password window!"
End If
End Sub
Sheet1(LookUp):
Private Sub Worksheet_Change(ByVal Target As Range)
LooupValue = Target.Value
part = Application.VLookup(LooupValue, MasterSheet.Range("A:AO"), 7, False)
desc = Application.VLookup(LooupValue, MasterSheet.Range("A:AO"), 9, False)
cust = Application.VLookup(LooupValue, MasterSheet.Range("A:AO"), 10, False)
due = Application.VLookup(LooupValue, MasterSheet.Range("A:AO"), 13, False)
If Not Application.Intersect(Range("A:A"), Target) Is Nothing Then
Range(Target.Address).Offset(0, 3).Value = part
Range(Target.Address).Offset(0, 4).Value = desc
Range(Target.Address).Offset(0, 5).Value = cust
Range(Target.Address).Offset(0, 6).Value = due
End If
If Not Intersect(Target, Range("H:H")) Is Nothing Then
UserForm2.Show
Application.EnableEvents = False
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sheet1.Rows(Target.Row).Cut Sheet1.Rows(lastRow).Offset(1, 0)
Application.EnableEvents = True
Application.CutCopyMode = False
On Error Resume Next
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End Sub
Userform2 is probably popping up because this If Not Intersect(Target, Range("H:H")) Is Nothing Then is always evaluating to true. Does the range being passed into worksheet change always contain "H"?
I have created a form that will give the user the choice to pick from 7 different options which will all be default blank. When they click the cell next to the option it will change from blank to "yes" and when clicked again it will remove the text and so on. Cells R33 and S33 are merged and the code works fine there but i need the code to run across multipe cells that are also merged such as (R35-S35, R37-S37, R39-S39 & R41-S41.
Can you help me out with this please?
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("R33").MergeArea) Is Nothing Then
Select Case True
Case Target.Cells(1) = "yes"
Target.Cells(1) = ""
Case Target.Cells(1) = ""
Target.Cells(1) = "yes"
End Select
Range("A1").Select
End If
Application.EnableEvents = True
End Sub
You can select multiple cells and that should be accounted for. A static union of the merge areas will not have to be redefined on every selection.
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
static mrng as range
if mrng is nothing then
set mrng = union(cells(33, "R").mergearea, cells(35, "R").mergearea, _
cells(37, "R").mergearea, cells(39, "R").mergearea, _
cells(41, "R").mergearea)
end if
If Not Intersect(Target, mrng) Is Nothing Then
Application.EnableEvents = False
dim t as range
for each t in Intersect(Target, mrng)
select case lcase(t.value2)
case "yes"
t = vbnullstring
case else
t = "Yes"
end select
next t
Range("A1").Select
End If
Application.EnableEvents = True
End Sub
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 have a workbook in which specific line items are to be completed by a staff member and, once completed, they are to be checked off as complete. This triggers the row/range to the left of the checkbox to be selected, copied and pasted into the next worksheet on the first available row. The current row is then cleared from the first worksheet. Each worksheet has the checkboxes pre-filled in and pre-linked to cells. The issue I'm having is that when the checkbox is selected, the runall macro activates on the row that is currently selected instead of the row that the checkbox resides in and is linked to the cell in. So, for example, if the checkbox is in row M2 but the currently selected cell is B8, the macro will try to copy and paste row 8 instead of the intended row 2. As there is no undo with macros this results in a major headache. Any help would be greatly appreciated!
Sub RUNALLOPEN()
Dim response As VbMsgBoxResult
response = MsgBox("Are you sure you wish to clear this row and send to the Lab?", vbYesNo + vbExclamation, "Confirm Error Resolution")
If response = vbNo Then
Dim cbx As CheckBox
Set cbx = ActiveSheet.CheckBoxes(Application.Caller)
With cbx.TopLeftCell.Offset(0, -1)
cbx.Value = xlOff
End With
Exit Sub
End If
If response = vbYes Then
'rest of code
Call movedataOPEN2LAB
Call clearcellsOPEN
End If
End Sub
Sub movedataOPEN2LAB()
Dim cbx As CheckBox
'Application.Caller returns the name of the CheckBox that called this macro
Set cbx = ActiveSheet.CheckBoxes(Application.Caller)
'.TopLeftCell returns the cell address located at the top left corner of the cbx checkbox
With cbx.TopLeftCell.Offset(0, -1)
'Check the checkbox status (checked or unchecked)
If cbx.Value = xlOn Then
' Checkbox is Checked
Range(Cells(cbx.TopLeftCell.Offset(0, -1).Row, 1), Cells(cbx.TopLeftCell.Offset(0, -1).Row, 11)).Select
Selection.Copy
Sheets("Lab").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
ActiveSheet.Range("H" & Selection.Row).Formula = "=VLOOKUP(INDIRECT(""G"" & ROW()),'Source Data'!$D$1:$J$36,6,FALSE)"
ActiveSheet.Range("I" & Selection.Row).Value = "Lab"
Range("A2").Select
End If
End With
End Sub
Sub clearcellsOPEN()
On Error Resume Next
Worksheets("Open").Activate
Range(Cells(Selection.Row, 1), Cells(Selection.Row, 15)).Select
Selection.SpecialCells(xlCellTypeConstants).ClearContents
Range(Cells(Selection.Row, 1), Cells(Selection.Row, 1)).Select
End Sub
Thank you for your help! Here's what I came up with:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 13 Then
'If UCase(Target.Value) <> "X" Then
' Dim response As VbMsgBoxResult
' response = MsgBox("You must input 'x' in order to move this row.", vbOKOnly + vbExclamation, "ERROR")
' Exit Sub
' End If
If UCase(Target.Value) = "X" Then
response = MsgBox("Are you sure you wish to clear this row and send to the Lab?", vbYesNo + vbExclamation, "Confirm Error Resolution")
If response = vbNo Then
Target.Value = ""
Exit Sub
End If
If response = vbYes Then
'rest of code
Target.Cells.Offset(0, -12).Select
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 11)).Select
Selection.Copy
With Sheets("Lab")
.Select
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
End With
ActiveSheet.Paste
ActiveSheet.Range("H" & Selection.Row).Formula = "=VLOOKUP(INDIRECT(""G"" & ROW()),'Source Data'!$D$1:$J$36,6,FALSE)"
ActiveSheet.Range("I" & Selection.Row).Value = "Lab"
With Sheets("Open")
.Select
On Error Resume Next
Target.Cells.Offset(0, -12).Select
Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 14)).Select
Selection.SpecialCells(xlCellTypeConstants).ClearContents
End With
End If
End If
End If
End Sub
There are many other ways to accomplish that than checkboxes... A "cleaner" one that comes to my mind is to use the Change event of the worksheet.
get rid of the checkboxes
Set the title of Column M to "Completed = X"
Use this code in the Table Object:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 13 Then
If uCase(Target.Value) = "X" Then
'--Write your copy-code here maybe ignore/delete the x first
MsgBox "CopyThat!"
End If
End If
End Sub
just a suggestion...
I'm trying to automatically update the "Updated" column of an excel spreadsheet when any cell of that specific row changes to today's date. I was able to do this by hard-coding where the "Updated" column header would be, however, it is now necessary to search for that column header as it may move.
The code I am trying to implement works but immediately gives me the error Automation error - The object invoked has disconnected from it's clients.
Any help would be appreciated. Here is the code I have currently:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If Not f Is Nothing Then
Range(Split(f.Address, "$")(1) & Target.Row).Value = Now
Else
MsgBox "'Updated' header not found!"
End If
End If
End Sub
You got into an endless loop.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If f Is Nothing Then
MsgBox "'Updated' header not found!"
ElseIf Intersect(Target, f.EntireColumn) Is Nothing Then
Intersect(Target.EntireRow, f.EntireColumn).Value = Now
' Else
' MsgBox "We entered this function again because the row above updated the Updated column", vbInformation, "False alarm"
End If
End If
End Sub
To understand what happens,
Uncomment the else and MsgBox
Put a breakpoint on the MsgBox
When you hit it, press [ctrl]-L
In a case such as this, I run into far fewer problems when I simply loop through the available cells to find the column header. Using the .Find method also works, but is less "tunable" to my needs in a custom application.
Public Function FindColumn(header As String) As Long
Dim lastCol As Long
Dim headerCol As Long
Dim i As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VTO2 Labor")
lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
headerCol = 0
For i = 1 To lastCol
If sh.Cells(1, i).Value = header Then
headerCol = i
End If
Next i
FindColumn = headerCol
End Function
It isn't clear on whether the Updated column header could be in row 1 or if it will always be in row 1, just not in the same location.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
On Error GoTo bm_SafeExit
'TURN OFF EVENTS IF YOU ARE GOING TO WRITE A VALUE INTO THE WORKSHEET!
Application.EnableEvents = False
Dim uCol As Long, f As Range
If Application.CountIf(Rows(1), "updated") Then
uCol = Application.Match("updated", Rows(1), 0)
For Each f In Intersect(Target, Range("A:DX"))
If f.Row > 1 Then _
Cells(f.Row, uCol) = Now
Next f
Else
MsgBox "'Updated' header not found!"
End If
End If
bm_SafeExit:
Application.EnableEvents = True
End Sub
That should survive multiple updates (e.g. when pasting values). The problem I see is that is the Updated column is being shifted around, presumably through inserting columns or the like, then the change routine is going to run.