I want to fill the cells with Character Abbreviation, according to the entering number in that cell.
For example I created the following image Where the Column L should be filled with DM, AG, IW, WSW, CW. For this purpose, I used numeric values from 1 to 5 (DM=1, AG=2, IW=3, WSW=4, CW=5). I already
For this, I already entered those values (AR6:AW17) as following in the same sheet.
Tried
I used the following code :
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("L:L")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim foundVal As Range
Set foundVal = Range("AR5:AV5").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(1, 0)
End If
Application.ScreenUpdating = True
End Sub
Problem
My question is how can I extend this to put the values to
Column L as AR6:AV6
Column M as AR7:AW7
Column P as AR8:AV8
Column Q as AR14:AU14
Column T as AR15:AV15
Column W as AR17:AU17
Updated
The column Q, T, W are added for more consideration please.
and so on, please?
Resize and Offset in Worksheet Change
Adjust the values in the constants section.
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ColRangesList As String = "L,M,N,P"
Const RowRangesList As String = "AR5:AV5,AR6:AW6,AR7:AS7;AT8:AX8"
Const RowOffset As Long = 1
Const ColOffset As Long = 0
If Target.Cells.CountLarge = 1 Then
Dim ColRanges() As String: ColRanges = Split(ColRangesList, ",")
Dim RowRanges() As String: RowRanges = Split(RowRangesList, ",")
Dim crg As Range, rrg As Range, cel As Range
Dim n As Long
For n = 0 To UBound(ColRanges)
Set crg = Columns(ColRanges(n))
Set rrg = Range(RowRanges(n))
If Not Intersect(Target, crg) Is Nothing Then
Set cel = rrg.Find(Target.Value, rrg.Cells(rrg.Cells.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole)
If Not cel Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Target.Value = cel.Offset(RowOffset, ColOffset).Value
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit For
End If
End If
Next n
End If
End Sub
Related
I have following code.
I need to get Cell value (old Value position), before event start
Maybe is some better way.
May you help me?
my idea is if you change cell in one row in actual sheet, changes will be updated in main sheet (LL-COVER)
Thank you very much
Private Sub Worksheet_Selection_Change(ByVal Target As Range)
Application.ScreenUpdating = False
oldValue = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
newValue = Target.Value
If oldValue <> newValue Then
Dim o As Integer
Dim b As String
Dim c As Integer
Dim g As Integer
Dim h As Integer
Set sh1 = ActiveSheet
Set sh2 = Sheets("LL-COVER")
On Error GoTo ProcError
o = oldValue.Row
c = oldValue.Column
sh1.Cells(o, c).Select
Selection.Copy
b = sh1.Cells(o, 1).Value
Sheets("LL-Cover").Select
On Error GoTo ProcError
Set fn = Range("A6:A150").Find(what:=b, LookIn:=xlValues, lookat:=xlWhole)
If Not fn Is Nothing Then
g = fn.Row
h = c
sh2.Cells(g, h).Select
ActiveSheet.Paste
End If
Range("A6:Q100").Sort Key1:=Range("D6"), Order1:=xlDescending
ProcError:
Exit Sub
oldValue = newValue
End If
If Not Intersect(Target, Range("H5:H150")) Is Nothing Then
Call Module1.Copy_UNI
Call Module2.control
End If
Sheets("LL-EE").Select
Application.ScreenUpdating = True
End Sub
I suppose the columns in your "actual sheet" (where you make the change) & the columns in the "LL-Cover" sheet (where the change needs to be replicated automatically) are the same. The following code needs to reside in the "actual sheet":
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim fn As Range
Dim c As Integer
Dim g As Integer
Set sh1 = ActiveSheet
Set sh2 = Sheets("LL-COVER")
c = Target.Column
b = sh1.Cells(Target.Row, 1).Value
With Sheets("LL-Cover").Range("A6:A150")
Set fn = .Find(b, LookIn:=xlValues)
g = fn.Row
sh2.Cells(g, c).Value = Target.Value
End With
End Sub
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'd like to add multiple criteria to this code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const srcCol As String = "A"
Const Criteria As String = "*high*"
Dim rng As Range: Set rng = Intersect(Columns(srcCol), Target)
If rng Is Nothing Then
Exit Sub
End If
Application.EnableEvents = False
Dim aRng As Range
Dim cel As Range
Dim foundCriteria As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If LCase(cel.Value) Like LCase(Criteria) Then
MsgBox ("Please check 2020 assessment")
foundCriteria = True
Exit For
End If
Next cel
If foundCriteria Then
Exit For
End If
Next aRng
Application.EnableEvents = True
End Sub
At the current state, this works in this way: if a cell of column "A" contains word "high", alert pop up.
I would like to add more criteria: if cell in column "A" contains "high" but ALSO if a cell in column "A" contains "critic", show me the same alert box.
I started from row "Const Criteria As String = "high", and tried adding "And", "Or", "If", "& _", but nothing seems working to add the second criteria.
Any hint?
A Worksheet Change: Target Contains One of Multiple Strings
If you plan on using exclusively contains for the various criteria, you can do the following changes:
Const CriteriaList As String = "high,critic" ' add more
If LCase(cel.Value) Like "*" & LCase(Criteria(n)) & "*" Then
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const srcCol As String = "A"
Const Delimiter As String = "," ' change if you need "," in the criterias
Const CriteriaList As String = "*high*,*critic*" ' add more
Dim rng As Range: Set rng = Intersect(Columns(srcCol), Target)
If rng Is Nothing Then
Exit Sub
End If
Dim Criteria() As String: Criteria = Split(CriteriaList, Delimiter)
Application.EnableEvents = False
Dim aRng As Range
Dim cel As Range
Dim n As Long
Dim foundCriteria As Boolean
For Each aRng In rng.Areas
For Each cel In aRng.Cells
For n = 0 To UBound(Criteria)
If LCase(cel.Value) Like LCase(Criteria(n)) Then
MsgBox ("Please check 2020 assessment")
foundCriteria = True
Exit For
End If
Next n
Next cel
If foundCriteria Then
Exit For
End If
Next aRng
Application.EnableEvents = True
End Sub
I want to find row number of first empty cell in column and store that row number in Cell Z1.
I tried with Following macro code but it goes into loop forever.
As soon as it tries to set the value in Cell Z1 it again goes into worksheet_change event again and then again in for loop.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(3).Cells
If IsEmpty(cell) = True Then Range("$Z$1").Value = cell.Row: Exit For
Next cell
End Sub
Please help to resolve this.
Thanks
Maybe this code is of any help
Option Explicit
Function firstEmptyCell(col As Long, Optional ws As Worksheet) As Range
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
Set firstEmptyCell = rg
End Function
And the Event code is
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EH
If Target.Column <> 12 Then
Exit Sub
End If
Application.EnableEvents = False
Range("Z1").Value = firstEmptyCell(12).Row
EH:
Application.EnableEvents = True
End Sub
Update: Based on the comments regarding the pitfalls of the change event one could change firstEmptyCell slightly and use a UDF only
Function firstEmptyCellA(col As Long, Optional ws As Worksheet) As Long
On Error GoTo EH
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Application.Volatile
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
firstEmptyCellA = rg.Row
Exit Function
EH:
firstEmptyCellA = 0
End Function
Tricky Enable Events
This is triggered only when a cell in the 12th column (L) is changed, otherwise there is no need for it. If you have formulas there, then this will not work and you'll have to use the Worksheet_Calculate event.
Row of First Empty Cell in Column
Option Explicit
' Row of First Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="", _
After:=Cells(Rows.Count, TargetColumn), LookIn:=xlValues)
If rng Is Nothing Then
Range(TargetCell).Value = 0 ' Full column. No empty cells.
Else
Range(TargetCell).Value = rng.Row
End If
Application.EnableEvents = True
End Sub
Row of First Empty Cell After Last Non-Empty Cell in Column
Option Explicit
' Row of First Empty Cell After Last Non-Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then ' Empty column. No non-empty cells.
Range(TargetCell).Value = 1
Else
If rng.Row = Rows.Count Then ' Last (bottom-most) cell is not empty.
Range(TargetCell).Value = 0
Else
Range(TargetCell) = rng.Offset(1).Row
End If
End If
Application.EnableEvents = True
End Sub
Dont need a loop. Paste this in a module not in a worksheet event unless you want it for every worksheet change.
Sub Macro1()
ActiveSheet.Range("Z1") = ActiveSheet.Columns(3).SpecialCells(xlCellTypeBlanks)(1).Row
End Sub
if you want it after every change then put it in a worksheet as. This code will not run everytime. It will check if Z1 is empty then enter the valu. Then if Z1 is not empty it will check if the target cell is in column C
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = ActiveSheet.Columns(3)
If IsEmpty(Range("Z1")) Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
Else
If Not Intersect(Range("C1:C" & Range("Z1").Value), Target) Is Nothing Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
End If
End If
End Sub
the combination of this sub in a module
Sub hithere3()
Dim Rng As Range
Dim Unique As Boolean
For Each Rng In Worksheets("Sheet8").Range("FS3:FS30") 'for each cell in your B1 to B30 range, sheet1
Unique = True 'we'll assume it's unique
Lastunique = Worksheets("TRADES").Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 3 To Lastunique 'for each cell in the unique ID cache
If Rng.Value = Worksheets("TRADES").Cells(i, 3).Value Then 'we check if it is equal
Unique = False 'if yes, it is not unique
End If
Next
If Unique Then Worksheets("TRADES").Cells(Lastunique + 1, 3) = Rng 'adds if it is unique
Next
End Sub
with the loop check in a worksheet change events
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
works except it only updates when I select one of the cells in FS3:FS33
Can anyone suggest how this can be overcome?
maybe with a workchange change range selection type from below?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim RngB As Range, RngC As Range
If Target.Column = 2 And Target.Count = 1 And Target.Row > 1 Then
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Set RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
Set RngC = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
ray = Array(RngB, RngC)
For n = 0 To 1
For Each Dn In ray(n)
If Not Dn.Address(0, 0) = "C1" And Not Dn.Value = "" Then
.Item(Dn.Value) = Empty
End If
Next Dn
Next n
Range("C2").Resize(.Count) = Application.Transpose(.Keys)
End With
End If
Use either the worksheet Calculate event or the worksheet Change event:
use Calculate if the range contains formulas
use Change if the cells in the range are changed manually
If Intersect(Target, Range("FS3:FS33")) Is Nothing is the culprit. You must change Range("FS3:FS33") to whatever range you want to affect this change.
Private Sub Worksheet_Change(ByVal Target As Range) '<<delete the "Selection" from the name of event
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
Finally figured it out, the following code works :
Private Sub Worksheet_calculate()
If Range("FS3:FS33") Is Nothing Then
'Do nothing'
Else
Call hithere3
End If
End Sub