I am trying to create a spreadsheet in which I need a button in each row to stamp the time in the cell next to it and then sort the rows in order of time. My problem is that the buttons do not move. E.g. Button in cell B1 changes time in cell A1 and button in cell B2 changes time in cell A2 and for this example lets say A2 has a lower time than A1 so when sorted A1 and A2 effectively swap data. Now the button in B2 changes the time in cell A1.
Been trying to figure this out for hours, any help would be greatly appreciated.
Based on David's comment, you can try this set up.
Dim r As Range
Private Sub CommandButton21_Click()
r.Offset(0, -1).Value = Time
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
If Target.CountLarge > 1 Then GoTo moveon
Dim btn As OLEObject: Set btn = Me.OLEObjects("CommandButton21")
If Not Intersect(Target, Me.Range("B:B")) Is Nothing Then
Set r = Target
With btn
.Visible = True
.Left = r.Left
.Top = r.Top
.Width = r.Width
.Height = r.Height
End With
Else
btn.Visible = False
End If
moveon:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume moveon
End Sub
You need to create an ActiveX Control with CommandButton21 as its name.
This buttons move and appear when something is selected in Column B.
You can add your sort routine on the CommandButton21_Click event.
Related
I need help in capturing the cell value on left mouse click. So when a user has done a single left mouse click in a particular cell then I need to capture that particular cell value (Value written in that cell) in the VBA code.
This value will then be passed on to the VBA code and the output will be different for click in different cells. I hope I was able to explain the purpose.
I have total of 10 cells where the left mouse click value is to be captured.
This code will check to see if multiple cells are selected at once then it checks to see if the cell is empty. If it is empty then it exits otherwise it stores the value is cell N1. You can change which cell the value gets stores at. If N1 has a value it goes to the next empty cell in column N.
Dim oval
Dim N As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count < 2 Then
If Target = Empty Then
Exit Sub
End If
oval = Target.Value
MsgBox "The value saved is " + oval + "."
If Range("N1").Value = "" Then
N = 1
Else
N = Cells(Rows.Count, "N").End(xlUp).Row + 1
End If
Cells(N, "N").Value = oval
End If
End Sub
If you would settle for a double mouse click, you could try something like
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
MsgBox Target.Value
Cancel = True
End Sub
How about this? Just wrote it, it will not register a mouse click if you click where you could have reached with the keyboard
Enter Under Worksheet Code:
XXXXXXX
Option Explicit
Private prevTarget As Range
Private Sub Worksheet_Activate()
Set prevTarget = Selection
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wasMouseClick As Boolean
Dim ch1, ch2, ch3, ch4, ch5, ch6, ch7, ch8, ch9 As String
On Error Resume Next
ch1 = prevTarget.Offset(1, 0).Address
ch2 = prevTarget.Offset(-1, 0).Address
ch3 = prevTarget.Offset(0, 1).Address
ch4 = prevTarget.Offset(0, -1).Address
ch5 = prevTarget.End(xlDown).Address
ch6 = prevTarget.End(xlToLeft).Address
ch7 = prevTarget.End(xlToRight).Address
ch8 = prevTarget.End(xlUp).Address
On Error GoTo error_noPreTarget
If Not (Target.Address = ch1 Or _
Target.Address = ch2 Or _
Target.Address = ch3 Or _
Target.Address = ch4 Or _
Target.Address = ch5 Or _
Target.Address = ch6 Or _
Target.Address = ch7 Or _
Target.Address = ch8) Then
wasMouseClick = True
End If
Set prevTarget = ActiveCell
If wasMouseClick Then
Debug.Print wasMouseClick ' replace with what you want when wasMouseClick = True
End If
Exit Sub
error_noPreTarget:
Set prevTarget = Selection
End Sub
I'm working on an Excel worksheet and using VBA to complete and update information on the cells.
There are seven columns in the Excel table. Three of them are drop-down lists with Data Validation, which I used the following VBA code to fill them.
Private Sub TempCombo_KeyDown(ByVal _KeyCode As MSForms.ReturnInteger, _ ByVal Shift As Integer)
'Ocultar caixa de combinação e mover a próxima célula com Enter e Tab
Select Case KeyCode
Case 9
ActiveCell.Offset(0, 1).Activate
Case 13
ActiveCell.Offset(1, 0).Activate
Case Else
'Nada
End Select
End Sub
These columns also work with autocomplete, using the code below:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Set ws = ActiveSheet
Set wsList = Sheets(Me.Name)
Application.EnableEvents = False
Application.ScreenUpdating = False
If Application.CutCopyMode Then
'Permite copiar e colar na planilha
GoTo errHandler
End If
Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
With cboTemp
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With
cboTemp.Activate
'Abrir a lista suspensa automaticamente
Me.TempCombo.DropDown
End If
errHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End Sub
Anytime I update any cell on a row, I want that the content of the seventh column of this row is updated with the current date.
I tried using the following code, but it only works with common cells, the ones that I manually type its content. I want the seventh column to be updated when I change the drop-down list selection also.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Then Exit Sub
Application.EnableEvents = False
Cells(Target.Row, "U").Value = Date
End Sub
Is there any way to update the content of the column as I said before? Even when I change the option selected in the drop-down list?
Your code is fine except that you need to turn events back on. You have stopped events from firing with this line: Application.EnableEvents = False but you never turn the event firings back on again. So your code will work the first time you change a cell, the Worksheet_Change event will fire as expected. However, within this sub you have set EnableEvents to false and then never set it back to true. So you have stopped all future events, including this one, from firing again in the future. Here is the solution:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Then Exit Sub
Application.EnableEvents = False
Cells(Target.Row, "U").Value = Date
Application.EnableEvents = True
End Sub
I have a few cases that trigger on change.
They are working as I wish. If D21 is blank then nothing happens. If anything is in it A message box comes up.etc.
The problem is that I also have a clear Cells button that triggers a change event on D21 when I don't want the message box to come up. Just clear all of the cells.
Here is how I have the cases written.
Private Sub Worksheet_Change(ByVal Target As range)
Application.EnableEvents = False '<--| disable events handling
On Error GoTo ErrorHandler '<--| be sure to catch any error and enable events handling back
Select Case Target.Address
Case "$D$4"
Me.Unprotect
'Recalculate Downpayment D5 if Purchase Price is changed
range("D5").Value = (range("D4").Value * range("B5").Value) / 100
Debug.Print "New value for D5 Downpayment "; range("D5").Value
range("D6").Value = (range("D4").Value - range("D5").Value) ' This cell won't activate when locked and sheet protected
Debug.Print "D6 New Mortgage " & range("D6").Value
Me.Protect
If range("D21") <> 0 Then
MsgBox "The Total Mortgaged Amount has changed, The Mortgage Payment Amount (Cell D21) is no longer valid. Please Re-calculate Mortgage with New Amount"
End If
Here is how I have the clear button written
Sub ClearTEst()
Dim ws As Worksheet
Dim rRng As range
Dim rCell As range
Dim rRows As range
Set rRng = Sheet1.range("A1:D28")
For Each rCell In rRng.Cells
If rCell.Locked = False Then
If rCell <> range("E21") Then
range("B10") = 5
range("B14") = 0.4
range("B15") = 8
range("B16") = 0.4
range("B17") = 5
range("B18") = 5
' rCell.ClearContents
rCell = 0
End If
End If
Next rCell
End Sub
Is there any way to capture that the worksheet change was triggered by the clear button and not trigger the cases that call the message up. First I was thinking that if I could add a condition to the If range("D21") triggered by clear button then no message, if not then message.
Hope this makes sense. thanks
In order to disable your code from triggering events, you need to add the following code before the rest of your code:
Application.EnableEvents = False
' //////////////////////////////
' /// REST OF YOUR CODE HERE ///
' //////////////////////////////
Application.EnableEvents = True
End Sub
It's the first time I'm trying some VBA code, so it might be a very noob mistake but I just can't see it, this is my code:
Private Sub Worksheet_Change(ByVal Target As Range)
If InRange(ActiveCell, Range("N4:N33")) Then
If InStr(1, ActiveCell.Text, "EFECTIVO") > 0 Then
If (Not IsEmpty(ActiveCell.Offset(0, -1))) Then
If (ActiveCell.Offset(0, -1).Value > 0) Then
Cancel = True
Call RestaEfectivo
Range("F4").Select
End If
End If
End If
End If
End Sub
Function InRange(Range1 As Range, Range2 As Range) As Boolean
InRange = Not (Application.Intersect(Range1, Range2) Is Nothing)
End Function
Sub RestaEfectivo()
Range("F4").Value = Range("F4").Value - ActiveCell.Offset(0, -1).Value
End Sub
The idea is that I have a dropdown list on my cells N4 to N33, whenever I choose the option "EFECTIVO" it should take the value to the left of the ActiveCell (N#) and substract its value from the F4 cell. In essence F4 = F4 - N#.
The code does what it's supposed to do, however, it appears to execute 50 times? The original value of my F4 cell is 230, once I execute the code it turns into -20
Any idea where I messed up or if I'm missing some code, validation, etc?
As I said, I'm new to VBA for Excel Macros, so don't worry about pointing out noob mistakes.
You need to toggle the EnableEvents property of Application at the point where you call your RestaEfectivo sub-routine. Notice that during handling the Worksheet_Change event you call the RestaEfectivo sub-routine which fires the worksheet change event again - that is why your macro executes more than once.
You can make the code change like this:
Cancel = True
' turn off events to enable changing cell value without a new 'change' event
Application.EnableEvents = False
Call RestaEfectivo
' re-enable events to ensure normal application behaviour
Application.EnableEvents = True
Range("F4").Select
Update
OP asked a follow up question - how to make the range dynamic but ignore the bottom row as this would contain a SUM formula.
One possible solution is to check for the change in any cell of column N:
If InRange(ActiveCell, Range("N:N")) Then
And then recode the InRange sub - see the code comments for logic and assumptions:
Function InRange(Range1 As Range, Range2 As Range) As Boolean
Dim blnInRange As Boolean
Dim blnResult As Boolean
Dim blnCellHasSumFormula As Boolean
Dim blnCellIsEmpty As Boolean
'primary check for cell intersect
blnInRange = Not (Application.Intersect(Range1, Range2) Is Nothing)
If blnInRange Then
'follow-up checks
blnCellIsEmpty = (Range1.Value = vbNullString)
If blnCellIsEmpty Then
'cell in range but empty - assume beneath row with SUM
blnResult = False
Else
If Range1.HasFormula Then
'check for sum formula
blnCellHasSumFormula = (InStr(1, Range1.Formula, "SUM(", vbTextCompare) > 0)
If blnCellHasSumFormula Then
' cell in the SUM row
blnResult = False
Else
' cell is in range, not empty and not a SUM formula
blnResult = True
End If
Else
'assume non-empty cell without formula is good
blnResult = True
End If
End If
Else
blnResult = False
End If
'return to event handler
InRange = blnResult
End Function
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