In my excel sheet I am validating that a specific column should not be empty and its values should be unique. This validation should only be performed on Sheet1 but it is working for other sheets also.
My code is
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _ Cancel As Boolean)
Dim rngCell As Range
Dim lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value = 0 Then MsgBox ("Please enter a name in cell " & rngCell.Address) rngCell.Select
End If
Next
End Sub
The second validation for unique values is done by data validation functionality in excel.
How about a ActiveWorksheet.name check ?
like
Dim Sh as Object, rngCell as Range, lngLstRow As Long
For Each Sh in WorkSheets
If Sh.Name = "SpecialName" Then 'YourCodeNext
lngLstRow = Sh.UsedRange.Rows.Count
For Each rngCell In Range("A1:A" & lngLstRow).Cells
If rngCell.Value = 0 Then MsgBox _
("Please enter a name in cell " & rngCell.Address) rngCell.Select
End If
Next rngCell
End If
Next Sh
Or if you know specific value of cell or range in your list.
For Each Sh in WorkSheets
If Sh.Range("K10").Value = "YourUnicValue" Then 'YourCodeNext
Also I'm not sure about your rngCell, if you want to check every cell in range, you need to use it like that.
For Each rngCell In Range("A1:A" & lngLstRow).Cells
Related
I'm trying to update cells that have data validation restrictions on them automatically.
For example - Sheet1 has below column (Column E):
Package Identifier
A
B
C
where the values are taken from the same named column (Column D) in Sheet2.
The below code works for MANUAL changes only
Sheet2 Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim count_cells As Integer
Dim new_value As String
Dim old_value As String
Dim rng As Range
For count_cells = 1 To Range("D1").CurrentRegion.Rows.Count - 1
Set rng = Worksheets("Sheet1").Range("E3:E86")
If Intersect(Target, Range("D" & count_cells + 1)) Is Nothing Then
Else
Application.EnableEvents = False
new_value = Target.Value
Application.Undo
old_value = Target.Value
Target.Value = new_value
rng.Replace What:=old_value, Replacement:=new_value, LookAt:=xlWhole
Target.Select
End If
Next count_cells
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
So, if i manually change value B to Z, all the corresponding values that were B on Sheet1 now change to Z. The problem is, Package Identifier on Sheet2 is dictated by concatenating other columns
=CONCATENATE(B35, "-", "Package", "-", TEXT(C35, "#000"))
This piece of code breaks when trying to use it with the above formula. How can i make this set of code trigger on this formula based output?
Assuming this is how the Validation sheet looks
and this is how the Source sheet looks
Let's say user selects first option in Validation sheet.
Now go back to Source sheet and change 1 to 2 in cell C2.
Notice what happens in Validation sheet
If this is what you are trying then based on the file that you gave, test this code.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim NewSearchValue As String
Dim OldSearchValue As String
Dim NewArrayBC As Variant
Dim OldArrayA As Variant, NewArrayA As Variant
Dim lRow As Long, PrevRow As Long
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Range("B:C")) Is Nothing Then
lRow = Range("A" & Rows.Count).End(xlUp).Row
'~~> Store new values from Col A, B and C in an array
NewArrayBC = Range("B1:C" & lRow).Value2
NewArrayA = Range("A1:A" & lRow).Value2
Application.Undo
'~~> Get the old values from Col A
OldArrayA = Range("A1:A" & lRow).Value2
'~~> Paste the new values in Col B/C
Range("B1").Resize(UBound(NewArrayBC), 2).Value = NewArrayBC
'~~> Loop through the cells
For Each aCell In Target.Cells
'~~> Check if the prev change didn't happen in same row
If PrevRow <> aCell.Row Then
PrevRow = aCell.Row
NewSearchValue = NewArrayA(aCell.Row, 1)
OldSearchValue = OldArrayA(aCell.Row, 1)
Worksheets("Validation").Columns(2).Replace What:=OldSearchValue, _
Replacement:=NewSearchValue, Lookat:=xlWhole
End If
Next aCell
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
A different approach from Sid's...
Instead of updating values in the DV cells when the source range changes, this replaces the selected value with a link to the matching cell in the DV source range.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngV As Range, rng As Range, c As Range, rngList As Range
Dim f As Range
On Error Resume Next
'any validation on this sheet?
Set rngV = Me.Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'no DV cells...
Set rng = Application.Intersect(rngV, Target)
If rng Is Nothing Then Exit Sub 'no DV cells in Target
For Each c In rng.Cells
If c.Validation.Type = xlValidateList Then 'DV list?
Set rngList = Nothing
On Error Resume Next
'see if we can get a source range
Set rngList = Evaluate(c.Validation.Formula1)
On Error GoTo 0
If Not rngList Is Nothing Then
Application.EnableEvents = False
'find cell to link to
Set f = rngList.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
Application.EnableEvents = False
c.Formula = "='" & f.Parent.Name & "'!" & f.Address(0, 0)
Application.EnableEvents = True
End If
Else
Debug.Print "No source range for " & c.Address
End If
End If
Next c
End Sub
I have a ByVal code to clear the contents of a specific range inside a table, it works. But I need to add a condition for the instructions execute if the RANGE VALUE (content) change, not if I only place the cursor on it.
Also, someone knows how to reference a table column in VBA? Now I'm using an estimated range "C1:C999" but I'll like to use his name "A_[OPERATION]".
This is the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Range("C1:C999"), Range(Target.Address)) Is Nothing Then
Range(Selection, Selection.End(xlToRight)).ClearContents
End If
End Sub
You could use the change event instead.
Here's a link to the documentation:
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.change
Alternatively, you could save the value of your target cell in a variable and check if the value changed before executing your clear contents.
For your second question, you should probably ask about it in a separate post.
A Worksheet Change
Adjust the table name (tName) and the header (column) name (hName).
I have adjusted it to clear contents in the cells after the column.
If you really need to clear the contents of the column too, then replace cel.Offset(, 1) with cel.
In a table, the current setup will automatically clear the contents of all the cells to the right of the specified column, if a value in the column is manually or via VBA changed. This will not work if the column contains formulas. Non-contiguous deletions are also supported.
The code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ProcName As String = "Worksheet_Change"
On Error GoTo clearError
Const tName As String = "A_"
Const hName As String = "OPERATION"
Dim rng As Range
Set rng = Range(tName & "[" & hName & "]")
Set rng = Intersect(rng, Target)
If rng Is Nothing Then GoTo ProcExit
Application.EnableEvents = False
With ListObjects(tName).HeaderRowRange
Dim LastColumn As Long
LastColumn = .Columns(.Columns.Count).Column
End With
Dim cel As Range
For Each rng In rng.Areas
For Each cel In rng.Cells
With cel.Offset(, 1)
.Resize(, LastColumn - .Column + 1).ClearContents
End With
Next cel
Next rng
CleanExit:
Application.EnableEvents = True
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0
GoTo CleanExit
ProcExit:
End Sub
A change in cell value is captured by the Worksheet_Change event-handle.
However, this handle will trigger even if it is a false change. For example, if the cell value before the change is "A", and user just entered "A" again in the cell, the Change event procedure will be triggered anyhow.
To avoid this, we can use Worksheet_Change and Worksheet_SelectionChange together.
Using Worksheet_SelectionChange, we record the old value somewhere, say a Name. Then using Worksheet_Change, we can compare what the user has entered against the Name to see if a true change is made.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Nm As Name: Set Nm = ActiveWorkbook.Names("OldValue")
If Target.Count = 1 Then
'This only record one old cell value.
'To record multiple cells old value, use a hidden Worksheet to do so instead of a Name.
Nm.Comment = Target.Value2
else
Nm.Comment = Target.Value2(1, 1)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Nm As Name: Set Nm = ActiveWorkbook.Names("OldValue")
If Target.Value2 <> Nm.Comment Then
Debug.Print "True change"
Else
Debug.Print "False change"
End If
End Sub
You can access a table's methods and properties through the listobject object. Below is an example how to do so.
Sub Example()
Dim lo As ListObject
Dim lc As ListColumn
Set lo = Range("Table1").ListObject
Set lc = lo.ListColumns("Column2")
End Sub
That said, for your case, it would be Range("A_").ListObject.ListColumns("OPERATION").DataBodyRange.
I have an Excel sheet with 5 tabs, column A in each is where I want a clickable cell.
When that cell is clicked, I want it to cut the 4 cells to the right of it on the same row and paste it on the next tab.
Clicking A1 would cut B1, C1, D1, E1 and paste it on the next tab, on the next empty row.
Same with the next tab until that row has made it to the final tab.
All the data is on the first sheet, all the others are empty.
Once I click on the first sheet I want it to move to the next one, then when I click it on the next one I want it to move to the third one.
So far I have code that creates hyperlinks on the cells I highlight, but it displays (sheet name! cell number). I want to display a specific txt instead, like (complete) or (received). The display varies for each tab.
The code I have in the first sheet moves the cut row to the second sheet.
I tried pasting that code in the next sheet to move it to the third sheet but I get an error.
Code in module
Sub HyperActive()
Dim nm As String
nm = ActiveSheet.Name & "!"
For Each r In Selection
t = r.Text
addy = nm & r.Address(0, 0)
ActiveSheet.Hyperlinks.Add Anchor:=r, Address:="", SubAddress:= _
addy, TextToDisplay:=r.Text
Next r
End Sub
Code in sheet
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim r As Range
Set r = Range(Target.SubAddress)
r.Offset(0, 1).Resize(1, 4).Cut
Sheets("Wash Bay").Select
Worksheets("Wash Bay").Range("B" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End Sub
I'd suggest using the Workbook_SheetFollowHyperlink event here. This is the workbook-level event, as opposed to the worksheet-level Worksheet_FollowHyperlink event.
From the docs:
Occurs when you choose any hyperlink in Microsoft Excel...
Parameters
Sh : The Worksheet object that contains the hyperlink
Target: The Hyperlink object that represents the destination of the hyperlink
Add the following code to the ThisWorkbook module (not the sheet code module).
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
If Sh.Index = Me.Worksheets.Count Then Exit Sub ' Do nothing if `Sh` is the last worksheet
Dim nextWs As Worksheet
Set nextWs = Me.Worksheets(Sh.Index + 1)
With nextWs
Dim lastRow As Long
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
Dim rng As Range
Set rng = Sh.Range(Target.SubAddress)
rng.Offset(, 1).Resize(1, 4).Cut Destination:=nextWs.Range("B" & lastRow + 1)
Application.CutCopyMode = False
End Sub
IMPORTANT NOTE: In its current state, this assumes that the workbook only has worksheets (no chart sheets, for example).
EDIT: You can use this revised code if the workbook contains other sheet types besides worksheets:
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim indx As Long
indx = GetWorksheetIndex(Sh)
If indx = Me.Worksheets.Count Then Exit Sub
Dim rng As Range
Set rng = Sh.Range(Target.SubAddress)
Dim nextWs As Worksheet
Set nextWs = Me.Worksheets(indx + 1)
With nextWs
Dim lastRow As Long
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
rng.Offset(, 1).Resize(1, 4).Cut Destination:=nextWs.Range("B" & lastRow + 1)
Application.CutCopyMode = False
End Sub
Private Function GetWorksheetIndex(ByVal ws As Worksheet) As Long
Dim w As Worksheet
For Each w In ws.Parent.Worksheets
Dim counter As Long
counter = counter + 1
If w.Name = ws.Name Then
GetWorksheetIndex = counter
Exit Function
End If
Next w
End Function
2nd EDIT:
I think you can rewrite HyperActive to something like this:
Sub HyperActive(ByVal rng As Range)
Dim ws As Worksheet
Set ws = rng.Parent
Dim fullAddress As String
fullAddress = "'" & ws.Name & "'!" & rng.Address
ws.Hyperlinks.Add Anchor:=rng, Address:="", SubAddress:=fullAddress, TextToDisplay:=rng.Text
End Sub
Then in the main Workbook_SheetFollowHyperlink code, add the following line:
HyperActive rng:=nextWs.Range("A" & lastRow + 1)
This is my first time trying to code with VBA. I have a drop down list in cell A2 and a drop down list in cell B2.
If A2 and B2 are populated (NotBlank?) then the user must enter text into D2 (I would like to make sure the text is longer than 10 characters- hoping no one presses the space bar 10 times) or they can't save (BeforeSave?) else they can save.
I need to make it loop as well. That is, if A3 and B3 are not empty then D3 is mandatory etc. I hope this is clear. Please let me know if I need to explain more.
Here is the code. It works for that one cell, but how do I make it repeat? Do I change the range?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If IsEmpty(Range("A2,B2")) = False Then
MsgBox "You must enter commentary to validate your ratings"
End If
End Sub
You need to loop through all used rows and check each cell on its own.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet 'specify which sheet here
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long 'find last used row in column A
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To LastRow 'loop throug all used rows
If ws.Cells(iRow, "A").Value <> vbNullString And _
ws.Cells(iRow, "B").Value <> vbNullString And _
ws.Cells(iRow, "D").Value = vbNullString Then
MsgBox "You must enter commentary to validate your ratings. This file will not be saved!", vbExclamation
Cancel = True 'do not save
ws.Cells(iRow, "D").Select 'select missing cell
Exit For
End If
Next iRow
End Sub
Another idea
This will automatically select all missing cells, and has no loops.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim ConstantsInA As Range
Set ConstantsInA = ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants)
Dim ConstantsInB As Range
Set ConstantsInB = ws.Range("B2:B" & LastRow).SpecialCells(xlCellTypeConstants)
Dim EmptyCellsInD As Range
Set EmptyCellsInD = ws.Range("D2:D" & LastRow).SpecialCells(xlCellTypeBlanks)
Dim MissingValues As Range
Set MissingValues = Intersect(ConstantsInA.EntireRow, ConstantsInB.EntireRow, EmptyCellsInD)
If Not MissingValues Is Nothing Then
MissingValues.Select 'select missing cells
MsgBox "You must enter commentary to validate your ratings. This file will not be saved!", vbExclamation
Cancel = True 'do not save
End If
End Sub
This should do what you want it to
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim c As Range
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For Each c In Sheets("Sheet1").Range("A2:A" & LastRow)
If c.Value <> "" And c.Offset(0, 1).Value <> "" And c.Offset(0, 3).Value = "" Then
MsgBox "You must enter commentary in column D" & c.Row & " to validate your ratings before saving"
Cancel = True
End If
Next
End Sub
I used IsEmpty() to determine whether a cell has a value in it and display a message that cells are missing data before letting the file print. I want to be able to specify which cells are missing by showing a message that states which cells have no data and not let the file print until all fields have a value.
Also, instead of displaying the cell address that has no value, would it be possible to show the defined name for that cell within the worksheet? I.e C2 is Name, F2 is Date....
Private Sub Workbook_BeforePrint(Cancel As Boolean)
If IsEmpty([C2]) Or IsEmpty([F2]) Or IsEmpty([K2]) Or IsEmpty([N2]) _
Or IsEmpty([C3]) Or IsEmpty([A8]) Or IsEmpty([F8]) _
Or IsEmpty([C34]) Or IsEmpty([C35]) _
Or IsEmpty([C36]) Or IsEmpty([C37]) Or IsEmpty([G35]) _
Or IsEmpty([G36]) Or IsEmpty([G37]) Or IsEmpty([I35]) _
Or IsEmpty([I36] Or IsEmpty([I37]) _
Or IsEmpty([L11]) Or IsEmpty([L18]) Or IsEmpty([L25]) _
Or IsEmpty([J28]) Or IsEmpty([N28]) Then
Cancel = True
MsgBox ("Missing Cell. Please verify form!")
End If
End Sub
You may try something like this...
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim rng As Range, cell As Range
Dim EmptyFound As Boolean
Dim str As String
Set rng = Range("C2:C3,F2,K2,N2,A8,F8,L11,L18,L25,J28,N28,C34:C37,G35:G37,I35:I37")
str = "The following cells are empty. Please verify form!" & vbNewLine & vbNewLine
For Each cell In rng
If IsEmpty(cell) Then
EmptyFound = True
str = str & cell.Address(0, 0) & vbNewLine
End If
Next cell
If EmptyFound Then
Cancel = True
MsgBox str, vbExclamation, "Empty Cells Found!"
End If
End Sub
another take:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim arr
arr = Array("C2", "F2", "K2", "N2", "C3", "A8", "F8", "C34:C37", "G35:G37", "I35:I37")
With Worksheets("Sheet1") ' Change to your sheet.
Dim rng As Range
Dim i As Long
For i = LBound(arr) To UBound(arr)
If rng Is Nothing Then
Set rng = .Range(arr(i))
Else
Set rng = Union(rng, .Range(arr(i)))
End If
Next i
Dim rng2 As Range
Set rng2 = .Range("A2:I37").SpecialCells(xlCellTypeBlanks)
Dim oRange As Range
Set oRange = Intersect(rng, rng2)
If Not oRange Is Nothing Then
MsgBox ("Missing Cell. Please verify form!") & vbNewLine & oRange.Address
Cancel = True
End If
End If
End Sub