Hi could someone help adjust this so the alert message says the value of A2 AND B2.
Private Sub Worksheet_Calculate()
Dim myRange As Range
Set myRange = ActiveSheet.Range("F2:F2")
Dim cell As Range
For Each cell In myRange
Evaluate (cell)
If StrComp(cell, "Yes", vbTextCompare) = 0 Then
MsgBox Join(Application.WorksheetFunction.Transpose(Range("A1:A10").Value), Chr$(10))
End If
Next
End Sub
I have modified my original post to comply with your better explanation.
Sub Worksheet_Calculate()
Dim myRange As Range
Dim Cell As Range
Set myRange = ActiveSheet.Range("F2:F2")
For Each Cell In myRange
Evaluate (Cell)
If StrComp(Cell, "Yes", vbTextCompare) = 0 Then
MsgBox "A2 = " & CStr((Cells(2, "A").Value) & vbCr & _
"B2 = " & CStr(Cells(2, "B").Value))
End If
Next Cell
End Sub
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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("F2:F220")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Range("G2:G220").Value < 0 Then
MsgBox "Cell " & Target.Address & " has changed."
End If
End If
End Sub
There's a formula in column G that calculates the value from numbers in column F. I wanted a popup when a result in G has a negative value. The type mismatch is on the line If Range("G2:G220") ... The column is formatted as Number, but it shows as Variant/Variant. I assume this is because the cell contents are actually a formula?
Is there a way round this without introducing 'helper' columns?
This is only my second bit of VBA so I'm happy to hear if you spot any other errors!
Restrict the Number of Results
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const KeyAddress As String = "F2:F220"
Const CheckColumn As Variant = "G" ' e.g. "A" or 1
Const MaxResults As Long = 1
' Define 'KeyCells'.
Dim KeyCells As Range: Set KeyCells = Range(KeyAddress)
' Define the range of cells that have changed and are part of 'KeyCells'.
Dim rng As Range: Set rng = Application.Intersect(Target, KeyCells)
' Check if there are any cells that have changed and are part of 'KeyCells'.
If rng Is Nothing Then Exit Sub
' Check if there is more than 'MaxResults' cells that have changed and
' are part of 'KeyCells'.
If rng.Cells.Count > MaxResults Then GoSub checkMoreCells
' Calculate the offset between 'Key' and 'Check' columns.
Dim ColOff As Long: ColOff = Columns(CheckColumn).Column - KeyCells.Column
Dim cel As Range
For Each cel In rng.Cells
' Check if the value in 'Check' column is negative.
If cel.Offset(, ColOff).Value < 0 Then
MsgBox "Cell '" & cel.Address(False, False) & "' has changed " _
& "to '" & cel.Value & "'."
End If
Next cel
Exit Sub
checkMoreCells:
Dim msg As Variant
msg = MsgBox("There could be '" & rng.Cells.Count & "' results. " _
& "Are you sure you want to continue?", _
vbYesNo + vbCritical, _
"More Than One Cell")
If msg = vbYes Then Return
Exit Sub
End Sub
Something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
Set rng = Application.Intersect(Range("F2:F220"), Target) 'Target is already a Range...
'any changed cells in F2:F220 ?
If Not rng Is Nothing Then
'loop over the changed cell(s)
For Each c in rng.Cells
'check value in ColG...
If c.Offset(0, 1).Value < 0 Then
MsgBox "Cell " & c.Address & " has changed."
End If
Next c
End If
End Sub
Edit: I realize it's not exactly clear whether you want to know if there's any negative numbers in Col G, or if you want to track row-by-row. This code does the latter.
In my excel in the column A, there are some date format and some text, I need to identity if each cell in column A if it is a date format or not date format:
Below is my code i try to loop each cell, but it identifies only cell A2, ANy help and ideas . Thanks
Dim strDate As String
Dim rng As Range, cell As Range
Set rng = Range("A2:A17")
With ThisWorkbook.Worksheets("Feuil1")
For Each cell In rng
MsgBox (cell.Value)
strDate = .Range("A2").Value
If IsDate(strDate) Then
MsgBox "This is a date format"
Else
MsgBox "This is not a date format"
End If
Next cell
End With
End Sub
It is because you are assigning .range("A2") to strDate; use the cell object from the for each loop:
Option Explicit
Public Sub CheckDates()
Dim strDate As String
Dim rng As Range, cell As Range
Set rng = Range("A2:A17")
With ThisWorkbook.Worksheets("Sheet1")
For Each cell In rng
MsgBox (cell.Value)
strDate = cell.Value
If IsDate(strDate) Then
MsgBox "This is a date format"
Else
MsgBox "This is not a date format"
End If
Next cell
End With
End Sub
In case you have many lines to check is better to use an array which is faster:
Sub test()
Dim i As Long
Dim arr As Variant
With ThisWorkbook.Worksheets("Feuil1")
arr = .Range("A2:A17")
For i = LBound(arr) To UBound(arr)
If IsDate(arr(i, 1)) Then
MsgBox "This is a date format"
Else
MsgBox "This is not a date format"
End If
Next i
End With
End Sub
I'd appreciate any help as I have no experience in vba.
What I'm trying to do
is that at the sheet "data" when the selected cell belongs to the rng1 then
the value for example 020318 at the cell changes to take the format 02/03/18.
At the same time in column ED at each cell there is a sum formula.
When this sum is under zero then a msgbox should pop up
for example
Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Set rng1 = ThisWorkbook.Sheets("DATA").Range("I3:I1000,O3:O1000,P3:P1000,AE3:AE1000,AF3:AF1000,AH3:AH1000,AI3:AI1000")
Set rng2 = ThisWorkbook.Sheets("DATA").Range("ED3:ED1000")
If Not Intersect(ActiveCell, Range("I3:I1000,O3:O1000,P3:P1000,AE3:AE1000,AF3:AF1000,AH3:AH1000,AI3:AI1000")) Is Nothing Then
For Each cell In rng1
If cell <> "" Then
If Len(cell) = 6 Then
cell.Value = Format(cell.Value, "00/00/00")
End If
End If
Next cell
For Each cell In rng2
If IsNumeric(cell) = True Then
If cell.Value < 0 Then MsgBox "Τhe salary " & Cells(cell.Row, 2).Value & " before ....is " & Cells(cell.Row, 3).Value & " try more", vbCritical, "XXXXX"
End If
Next cell
End Sub
thanks in advance
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