I want to prevent copy pasting data in excel if the data is not unique. Im using the following macro.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedCells As Range
Dim Cell As Range
Set AffectedCells = Intersect(Target, Target.Parent.Range("A:A"))
If Not AffectedCells Is Nothing Then
For Each Cell In AffectedCells
If CountIf(Range("A:A"),A1) >2 Then
MsgBox "The data """ & Cell.Value & """ inserted in " & Cell.Address & " in column A is duplicste. We undo!", vbCritical Application.Undo 'undo insert
Exit Sub
End If
Next Cell
End If
End Sub
It is still allowing the data to be pasted.
I tried letting excel not save itself if the value is duplicate but it is still saving.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rngCell As Range
Dim lngLstRow As Long lngLstRow = Sheet1.UsedRange.Rows.Count
For Each rngCell In Sheet1.Range("A1:A" & lngLstRow)
If CountIf(Range("A:A"),A1) > 2 Then
MsgBox "Please enter unique value " & rngCell.Address
rngCell.Select
End If
Next
End Sub
Related
I want the user's name and the date to be entered into a specified column when any change is made.
I also have a snippet of code that forces any data that is pasted into the sheet to be pasted as values so the sheet's formatting is maintained.
I was able to write code that functioned properly, but the event was also being triggered even when the user double clicked in a cell and clicked out of the cell (i.e., no change was made). A user could accidentally click into a cell and leave it without making changes, but their name would be left behind as having made an edit.
I tried to incorporate this solution. Here is a simplified version of my code:
Private Sub Worksheet_Change(ByVal Target as Range)
Dim DesiredRange as Range
Dim TOld, TNew as String
Set DesiredRange as 'Whatever range I'm using
If Not Intersect(Target, DesiredRange) is Nothing Then
TNew = Target.Value
With Application
.EnableEvents = False
.Undo
End With
TOld = Target.Value
Target.Value = TNew
If Application.CutCopyMode = xlCopy Then
Application.EnableEvents = False
Application.Undo
Target.PasteSpecial Paste:=xlPasteValues
Application.EnableEvents = True
End if
If TOld <> TNew Then
Target.Offset(0, 23 - Target.Column) = Application.Username & vbNewLine & Date
End If
Application.EnableEvents = True
End if
End Sub
I am encountering the following issue:
When a user double clicks into a cell and clicks into another cell, the event is not triggered (i.e., the user's name and date is not left in the cell) but the active cell is reverted into the original cell, rather than the one they clicked into after double-clicking.
So a user would double click into a cell, do nothing, then click into another cell, and the active cell would revert to the first cell they were in.
This is also happening after the user inputs their change into the cell and presses enter.
I also encounter an error when something is pasted into the sheet, causing the code to not execute properly.
Prevent Worksheet Change When No Change
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Dim srg As Range: Set srg = Range("B5:E10")
Dim irg As Range: Set irg = Intersect(srg, Target)
If irg Is Nothing Then Exit Sub
Dim coll As Collection: Set coll = New Collection
Dim iCell As Range
For Each iCell In irg.Cells
coll.Add iCell.Value
Next iCell
With Application
.EnableEvents = False
.Undo
End With
Dim drg As Range
Dim n As Long
For Each iCell In irg.Cells
n = n + 1
If iCell.Value <> coll(n) Then
iCell.Value = coll(n) ' write different value
If drg Is Nothing Then ' combine the cells for user and date
Set drg = iCell
Else
Set drg = Union(drg, iCell)
End If
End If
Next iCell
If Not drg Is Nothing Then
' Use 'Now' while testing or you will see no difference.
' Later switch to 'Date'.
Intersect(drg.EntireRow, Columns("W")).Value = Application.UserName _
& vbNewLine & Format(Now, "mm/dd/yyyy hh:mm:ss") ' Date
End If
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I have a problem with VBA, I need to use the worksheet change event to pickup cell values from AI28 to AI30 and move them over to V28 to V30. This is what I have do so far
Private Sub Worksheet_Change(ByVal Target As Range)
If IsNumeric(Target) And Not (Target = "") Then
If Target.Address = Range("AI28:AI30").Address Then
Range("V28:V30").Value = Range("AH28:AH30").Value
Else
If Target.Cells.Value <> Empty Then Exit Sub
Exit Sub
End If
End If
End Sub
It works fine for just one range eg AI28 and V28 so what am I missing? A loop or something?
Use a loop and Intersect:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Target, Me.Range("AI28:AI30"))
If rng Is Nothing Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell As Range
For Each cell In rng
If IsNumeric(cell.Value) And Not IsEmpty(cell.Value) Then
Me.Range("V" & cell.Row).Value = cell.Value
End If
Next
SafeExit:
Application.EnableEvents = True
End Sub
I'm creating macro Excel that will check if there is empty cells in specific range before closing the Workbook. I have an issue that the range is dynamic , and I have cell that contain the range that I want to check each time, how can I use cell value inside VBA as range.
and this is the VBA
Private Sub Workbook_BeforeClose(Cancel As Boolean)
For Each cell In Range("A2:E2")
If cell.Value = "" Then
MsgBox "Please, fill empty cells", vbInformation, "Warning"
cell.Select
Cancel = True
Exit Sub
End If
Next
End Sub
Private Sub Workbook_Open()
End Sub
thank you
Try this code
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim e, cell As Range
e = Range("O11").Value
If IsNumeric(Evaluate("SUM(" & e & ")")) And Not IsNumeric(e) Then
For Each cell In Range(e)
If cell.Value = "" Then
MsgBox "Please, Fill Empty Cells", vbInformation, "Warning"
cell.Select
Cancel = True: Exit Sub
End If
Next cell
End If
End Sub
Unfortunately Worksheet_change is not working for me. I am using a Sheet where the first column is NOW() function. If I click anywhere in the excel the time on this cell changes, but the Worksheet_Change just don't detect it.
A2 is using =NOW()
Anyone knows how to fix this issue? I have tried several different ways and no one works.
'Option Explicit
'Option Base 1
Dim xVal As Double
'Update by Extendoffice 2018/8/22
'Private Sub Worksheet_Calculate(ByVal Target As Range)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = Range("$A$2").Address Then
'Rows(3).Insert Shift:=xlDown
'Range("$A$3").Value = Now
'Range("$B$3").Value = xVal
'Range("$C$3").Value = Range("$C$2").Value
'Else
If xVal <> Range("$B$2").Value Then
Debug.Print xVal & " <- xVal IF"
Debug.Print Range("B2").Text & "<- Text IF"
Rows(3).Insert Shift:=xlDown
Range("$A$3").Value = Now
Range("$B$3").Value = xVal
Range("$C$3").Value = Range("$C$2").Value
End If
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
xVal = Range("$B$2").Value
End Sub
A Worksheet_Calculate Event Study
Google Drive
Cell A2 in worksheet Sheet1 contains the formula =B2.
Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
WsCalc
End Sub
' Only to trigger the calculate event when different cell is selected.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ThisWorkbook.Worksheets("Sheet1").Range("B2") = Int(Rnd() * 2 + 1)
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
WsCalc
End Sub
Module1
Option Explicit
Public lngSource As Long ' Current Source Value
Sub WsCalc()
Dim rngSource As Range ' Source Cell Range
' Create a reference to Source Cell Range (rngSource).
Set rngSource = ThisWorkbook.Worksheets("Sheet1").Range("A2")
' When the workbook opens, Current Source Valuec (lngSource) is equal to "".
' Therefore:
If lngSource = 0 Then
' Initialize Current Source Value (lngSource) i.e. write value
' of Source Cell Range (rngSource) to Current Source Value (lngSource).
lngSource = rngSource.Value
MsgBox "Monitoring started (lngSource=" & lngSource & ")."
Exit Sub
End If
' If you need disabling events, this is how you implement it. Not needed
' in this code.
' Application.EnableEvents = False
On Error GoTo ProgramError
' Check value of Source Cell Range (rngSource)
' against Current Source Value (lngSource).
If rngSource.Value <> lngSource Then
' The value has changed.
MsgBox "The value has changed from '" & lngSource & "' to '" _
& rngSource.Value & "'."
lngSource = rngSource.Value
Else
' The value hasn't changed (usually no code).
MsgBox "Value NOT changed, still '" & lngSource & "'"
End If
SafeExit:
' MsgBox "Enabling events before exiting."
' Application.EnableEvents = True
Exit Sub
ProgramError:
' Improve this error handling.
MsgBox "An unexpected error occurred."
On Error GoTo 0
GoTo SafeExit
End Sub
I made a Sub. But its giving an error.!
I want to check if column A has values then it checks for columns" H and I ". those must be filled.
Else the file wont save..!!
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim cell As Range
Dim LastRow As Long
Dim oneRange As Range
Dim aCell As Range
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
If cell.Value(Range("A8:A" & LastRow)) Is Nothing Then
Exit Sub
Else
For Each cell In Range("H8:I" & LastRow)
If IsEmpty(cell.Value) Then
MsgBox "Please Select Value from Dropdown Menu...." & cell.Address
Application.Goto cell
Cancel = True
Exit For
End If
Next cell
End If
End Sub
TRIED AND TESTED
Is this what you are trying?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim lRow As Long
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("receivings")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
If Application.WorksheetFunction.CountA(.Range("A8:A" & lRow)) = 0 _
Then Exit Sub
For Each aCell In Range("H8:I" & lRow)
If IsEmpty(aCell.Value) Then
MsgBox "Please Select Value from Dropdown Menu...." _
& aCell.Address
Application.Goto aCell
Cancel = True
Exit For
End If
Next aCell
End With
End Sub
sheet1 and sheets(1) is often not the same. Best is using the name of the sheet.
You might miss a "." at the second for (...in .range...) ?
PS, i'm new in VBA, what does application.goto aCell, do ? because it strage to put a "exit for" after a "goto"...