I have no experience in Visual Basic and I am trying to add or delete columns based on a cell value while keeping the same format from the first column. I´ve seen some posts but my programming knowledge is very basic and I can´t find a way to adjust variables for it to fit into my file.
The following code seems to work for the post I read but as I said I don´t know what to change for it to work in my file:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total") 'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2 'Column A & B for Company and ID
Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol To LeftFixedCol + ColNum
Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
Columns(i).Delete
Next i
End If
End Sub
Is it too much to ask if somebody could please help identifying each code line or give me a more simple code to work with?
The following gif shows exactly what I am trying to do:
Thanks beforehand!
A Worksheet Change: Insert or Delete Columns
This code mustn't be copied into a standard module, e.g. Module1 as you did.
It needs to be copied into a sheet module, e.g. Sheet1, Sheet2, Sheet3 (the names not in parentheses), of the worksheet where you want this to be applied. Just double-click on the appropriate worksheet in the Project Explorer window (seen on the top-left of your screenshot), copy the code to the window that opens and exit the Visual Basic Editor.
The code runs automatically as you change the values in the target cell (B1 with this setup) i.e. you don't run anything.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
' e.g. to prevent
' "Run-time error '1004': Microsoft Excel can't insert new cells because
' it would push non-empty cells off the end of the worksheet.
' These non-empty cells might appear empty but have blank values,
' some formatting, or a formula. Delete enough rows or columns
' to make room for what you want to insert and then try again.",
' which is covered for the header row, as long there is nothing
' to the right of the total column, but not for other rows.
Const TargetCellAddress As String = "B1"
Const TotalFirstCellAddress As String = "D3"
Const TotalColumnTitle As String = "Total" ' case-insensitive
Dim TargetCell As Range
Set TargetCell = Intersect(Me.Range(TargetCellAddress), Target)
If TargetCell Is Nothing Then Exit Sub ' cell not contained in 'Target'
Dim NewTotalIndex As Variant: NewTotalIndex = TargetCell.Value
Dim isValid As Boolean ' referring to an integer greater than 0
If VarType(NewTotalIndex) = vbDouble Then ' is a number
If Int(NewTotalIndex) = NewTotalIndex Then ' is an integer
If NewTotalIndex > 0 Then ' is greater than 0
isValid = True
End If
End If
End If
If Not isValid Then Exit Sub
Dim hrrg As Range ' Header Row Range
Dim ColumnsDifference As Long
With Range(TotalFirstCellAddress)
Set hrrg = .Resize(, Me.Columns.Count - .Column + 1)
If NewTotalIndex > hrrg.Columns.Count Then Exit Sub ' too few columns
ColumnsDifference = .Column - 1
End With
Dim OldTotalIndex As Variant
OldTotalIndex = Application.Match(TotalColumnTitle, hrrg, 0)
If IsError(OldTotalIndex) Then Exit Sub ' total column title not found
Application.EnableEvents = False
Dim hAddress As String
Select Case OldTotalIndex
Case Is > NewTotalIndex ' delete columns
hrrg.Resize(, OldTotalIndex - NewTotalIndex).Offset(, NewTotalIndex _
- ColumnsDifference + 2).EntireColumn.Delete xlShiftToRight
Case Is < NewTotalIndex ' insert columns
With hrrg.Resize(, NewTotalIndex - OldTotalIndex) _
.Offset(, OldTotalIndex - 1)
' The above range becomes useless after inserting too many columns:
hAddress = .Address
.EntireColumn.Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
End With
With Me.Range(hAddress)
.Formula = "=""Column""&COLUMN()-" & ColumnsDifference - 1
.Value = .Value
End With
Case Else ' is equal; do nothing
End Select
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 am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub
I,ve tried to find a VBA solution for finding the previous cell (located on the same row) with different value than the selected cell has. So if the selected cell is for example [N6] (as in my picture) then my search range should be ("A6:N6") from which I need to find the last cell with a different cell value (which would be cell [L6] in my picture because it's the previous cell with a different value than cell [N6]. The search should start from the end (N6,M6,L6...) backwards until the first match is found (first different cell value). When the first match is found then select it. I have hundreds of columns, so my picture is just to show the principle. I execute my vba code with Private Sub Worksheet_SelectionChange(ByVal Target As Range) so when the user selects a cell with the mouse. I get the desired cell with {=ADDRESS(6;MATCH(2;1/(A6:O6<>"D")))} but I would need a VBA solution for my problem. My current VBA solution takes me to cell [I6] instead of [L6] and I can't figure out how to edit my code to find the correct cell ([L6] in my example picture).
Dim rngSel As String, rngStart As String
Dim rngActiveStart As Range
rngSel = ActiveCell.Address(0, 0)
rngStart = Cells(ActiveCell.Row, 1).Address(0, 0)
Set rngActiveStart = Range(rngStart & ":" & rngSel)
Dim c
For Each c In rngActiveStart.Cells
If c <> Target.Value And c.Offset(0, 1) = Target.Value Then
c.Select
MsgBox "Previous different cell: " & c.Address(0, 0)
Exit For
End If
Next
Using selection_Change
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Long, col As Long, x
Dim v As String
r = Target.Row
v = Target.Value
Application.EnableEvents = False
For x = Target.Column To 1 Step -1
With Me
If .Cells(r, x) <> v Then
.Cells(r, x).Select
Exit For
End If
End With
Next x
Application.EnableEvents = True
End Sub
You need a For i = max To min Step -1 loop to loop backwards/left:
Public Sub MoveLeftUntilChange()
Dim SelRange As Range 'remember the selected range 'N6
Set SelRange = Selection
Dim iCol As Long
For iCol = SelRange.Column To 1 Step -1 'move columns leftwards
With SelRange.Parent.Cells(SelRange.Row, iCol) 'this is the current row/column to test againts the remembered range N6
If .Value <> SelRange.Value Then 'if change found select and exit
.Select
Exit For
End If
End With
Next iCol
End Sub
I have a sample table (B2:C4) with a couple of defined values "XXX = 10, YYY = 20, ZZZ = 30".
I have the second table (E2:F10) with drop down list in the column "E".
I need to copy value based on drop down list to column "F". It means for example when I select E3 = "XXX" from drop down list it copies appropriate value from column "C". In the example on the attached picture B1 = "XXX" -> C1 = "10" so the value will be copied to F3).
The problem is that the drop down list includes also another items than in the column "B2:B4" so I can customize the entry in the table.
I created working code but the issue is when I change any value in the column C2:C4 the value in the column F2:F10 does not change.
Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Res As Variant
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("E2:E10")) Is Nothing Then
Res = Evaluate("INDEX(C2:C4,MATCH(" & Target.Address & ",B2:B4,0))")
If Not IsError(Res) Then Target.Offset(, 1) = Res
End If
End Sub
Sample XLSM file
This is how I edited the sample table and the code according #Variatus:
The module code:
Enum Nws ' worksheet where 'Data' values are used
' 060
NwsFirstDataRow = 7 ' change to suit
NwsTrigger = 6 ' Trigger column (5 = column E)
NwsTarget = 8 ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1
NtaVal = 3
End Enum
And the sheet code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the sheet on which the "Data" range resides
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Set Ws = ThisWorkbook.Sheets("test") ' change to match your facts
Set Rng = Ws.Range("B2:D4") ' change to match your facts
With Application
Tmp = .VLookup(Target.Value, Rng, 3, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
End If
' skip action if more than one cell was changed
If Target.CountLarge > 1 Then Exit Sub
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Target.Offset(0, -1).Resize(, 2).Value
End If
End Sub
Private Sub Worksheet_Deactivate()
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
With Range("B2:D4") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
Application.EnableEvents = False
With TgtWs
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
.Cells(.Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
End With
Application.EnableEvents = True
End Sub
The code below differs from the selected answer in the following respects.
All the action now takes place on one sheet, as per your original question. Therefore all the code must now be placed in one location, on the code sheet of the worksheet on which everything transpires. In consequence thereof all worksheet specification could be removed from the code.
An extra column was interjected in the Data range of which, however, only the first and third columns are used, as identified in the Enum Nta.
Option Explicit
Enum Nws ' worksheet where 'Data' values are used
' 060-2
NwsFirstDataRow = 2 ' change to suit
NwsTrigger = 5 ' Trigger column (5 = column E)
NwsTarget ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1 ' 1st column of 'Data' range
NtaVal = 3 ' 3rd column of 'Data' range
End Enum
Private Sub Worksheet_Change(ByVal Target As Range)
' 060-2
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Application
Tmp = .VLookup(Target.Value, Range("Data"), NtaVal, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
Else
Set Rng = Range("Data") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, NtaVal).Value
End If
End If
End Sub
Private Sub Worksheet_activate()
' 060-2
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = Sheet1 ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060-2
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Application.EnableEvents = False
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
Application.EnableEvents = True
End Sub
My answer could be improved if you use Excel Tables
Also some parts of the code could be refactored. For example you should add some error handling.
But, this should get you started:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim watchRange As Range
Dim cellFormula As String
' Define the watched range
Set watchRange = Me.Range("E2:E10")
' Do this for each cell changed in target
For Each cell In Target.Cells
' Check if cell is in watched range
If Not Intersect(cell, watchRange) Is Nothing Then
cellFormula = "=INDEX(C2:C4,MATCH(" & Target.Address & ",B2:B4,0))"
' Check if formula doesn't return an error (this could be imporoved?)
If Not IsError(cellFormula) Then
' Don't fire the change event twice
Application.EnableEvents = False
cell.Offset(, 1).Formula = cellFormula
Application.EnableEvents = False
End If
End If
Next cell
End Sub
Let me know if this is what you needed and if it works.
If you wish to maintain a permanent link between your table B2:C4 and the results in column F you need to establish a robust system for updating changes. In effect, column F must not only change with the selection in column E but also with updates in column C. Presuming that these data are on different sheets in your project different worksheet events must be captured and coordinated. To be safe you should also update all occasionally, such as on Workbook_Open or Worksheet_Activate in case an update was missed due to a system crash.
None of that is particularly difficult to program but Excel offers a solution without VBA that is so stunningly better that it can't be ignored. Here it is.
Create a named range C2:C4. I called it "Data" and made it dynamic so that it can expand without requiring my attention.
Use the first column of this range to feed the data validation drop-down: =INDEX(Data,,1)
Use this formula in column F, =VLOOKUP(E2,Data,2,FALSE)
All conditions laid out above are met.
I'm trying to make it simple. So here is the origin table from my answer above where I just extend Data range and values in the column "C" are now in the column "D". Everything works except when I change value in the column "D" nothing happens:
sample table extended
Module code:
Enum Nws ' worksheet where 'Data' values are used
' 060
NwsFirstDataRow = 2 ' change to suit
NwsTrigger = 5 ' Trigger column (5 = column E)
NwsTarget ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1
NtaVal
End Enum
Test sheet code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the sheet on which the "Data" range resides
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Set Ws = ThisWorkbook.Sheets("test") ' change to match your facts
Set Rng = Ws.Range("Data") ' change to match your facts
With Application
Tmp = .VLookup(Target.Value, Rng, 3, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
End If
' skip action if more than one cell was changed
If Target.CountLarge > 1 Then Exit Sub
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Target.Offset(0, -1).Resize(, 2).Value
End If
End Sub
Private Sub Worksheet_Deactivate()
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
Application.EnableEvents = False
With TgtWs
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
.Cells(.Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
End With
Application.EnableEvents = True
End Sub
As promised above, the VBA solution is a lot more complicated than the one with VLOOKUP. But you can start in the same way. Create a named range where you store your "Categories" as I came to call them after I named the range "Data". This is a range with 2 columns, exactly as B2:C4 in your example. You can have this range on the same sheet as the action but I programmed in the assumption that it would be on another sheet.
Next, please install these enumerations in a standard code module. The first Enum identifies parts of the worksheet on which the range E:F of your example resides. It specifies row 2 as the first row with data, meaning row 1 will be omitted from scrutiny, and, in fact, assigns the job of columns 5 and 6, (E and F) of your example to the same columns in my code's output. You can change all of these values. The second enum identifies the columns of the 'Data' range. Naming these columns helps read the code. Changing the numbers makes no sense.
Enum Nws ' worksheet where 'Data' values are used
' 060
NwsFirstDataRow = 2 ' change to suit
NwsTrigger = 5 ' Trigger column (5 = column E)
NwsTarget ' Target column (no value = previous + 1)
End Enum
Enum Nta ' columns of range 'Data'
' 060
NtaId = 1
NtaVal
End Enum
The code below must be pasted to the code sheet of the worksheet on which you have the Data Validation drop-down. That is the one holding columns E:F of your example. Don't paste this code in the same module as the enumerations or any other standard code module. It must be the module assigned to the worksheet with these data. The code will check if an entry made in column E is present in 'Data' and get the value from there if it is. Else it will do nothing. Observe that this code needs to know where the category data are, worksheet and range name. I've marked the lines where you can change the specs.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the sheet on which the "Data" range resides
Dim Rng As Range
Dim Tmp As Variant
' skip action if more than 1 cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
Cells(Rows.Count, NwsTrigger).End(xlUp))
If Not Application.Intersect(Target, Rng) Is Nothing Then
Set Ws = Sheet1 ' change to match your facts
Set Rng = Ws.Range("Data") ' change to match your facts
With Application
Tmp = .VLookup(Target.Value, Rng, 2, False)
If Not IsError(Tmp) Then
.EnableEvents = False ' suppress 'Change' event
Cells(Target.Row, NwsTarget).Value = Tmp
.EnableEvents = True
End If
End With
End If
End Sub
Finally, there is code to go into the worksheet on which you have the category data (B2:C4 in your example). This, too, must be the code sheet attached to that worksheet, not a standard code module. There is a procedure called Worksheet_Change which is the same as a corresponding procedure for the other sheet. Since there can't be two procedures of the same name in the same module these two procedures would have to be merged if you eventually need both the 'Data' and the validations on the same worksheet as you have them in your example. The code is laid out to have them on separate sheets.
Option Explicit
Private Sub Worksheet_Deactivate()
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Cat As Variant ' 'Data' category (2 cells as Nta)
Dim R As Long ' loop counter: rows
Set TgtWs = Sheet2 ' change to match your facts
With Range("Data") ' change to match your facts
For R = 1 To .Rows.Count
Cat = .Rows(R).Value
UpdateCategory Cat
Next R
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' 060
Dim Ws As Worksheet ' the Tab on which 'Data' resides
Dim Rng As Range
' skip action if more than one cell was changed
If Target.CountLarge > 1 Then Exit Sub
Set Ws = Sheet1 ' change to suit
Set Rng = Ws.Range("Data") ' change to suit
If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
UpdateCategory Target.Offset(0, -1).Resize(, NtaVal).Value
End If
End Sub
Private Sub UpdateCategory(Cat As Variant)
' 060
Dim TgtWs As Worksheet ' the Tab on which 'Data' was used
Dim Fnd As Range ' matching cell
Dim FirstFound As Long ' row of first match
Dim Rng As Range
Set TgtWs = Sheet2 ' change to match your facts
Application.EnableEvents = False
With TgtWs
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
.Cells(.Rows.Count, NwsTrigger).End(xlUp))
With Rng
Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
If Not Fnd Is Nothing Then
FirstFound = Fnd.Row
Do
TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
Set Fnd = .FindNext(Fnd)
If Fnd Is Nothing Then Exit Do
Loop While Fnd.Row <> FirstFound
End If
End With
End With
Application.EnableEvents = True
End Sub
These three procedures work to maintain synch between the categories and the data, meaning, if a change occurs in the categories the data should reflect them. The key to this is the procedure UpdateCategory which looks for the category name in the data and ensures that it's the same as in the categories table. This procedure is called in two different ways.
One is when the value of a category is changed. It will then update that particular category. The other I have timed with the deactivation event of the worksheet. At that time all categories are updated, just in case an individual update has failed earlier. If you have a lot of data, or a lot of categories, this may prove slow. If so, there are ways to make it work faster.
I draw your attention to the need to specify both worksheets and the name of the 'Data' range in these procedures as well. The locations are marked. Please look for them.
I am a beginner in VBA.
I have a Column "A" can have multiple values, of which 2 are "Impact Assessed" or "Ready for retesting".
Problem Statement - I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively.
Below is my code -
Private Sub Worksheet_Calculate()
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("AA:AA"), Target)
If Not rng Is Nothing Then
Select Case (rng.Value)
Case "2 - Impact Assessed": rng.Offset(0, 1).Value = Date
Case "4 - Ready for retesting": rng.Offset(0, 2).Value = Date
End Select
End If
End Sub
I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the Criteria variable to suit your worksheet and you can change your sheet as you like without needing to modify the code.
Private Sub Worksheet_Change(ByVal Target As Range)
' 040
Const TriggerClm As String = "A" ' change to suit
Const WriteToClm As String = "B" ' the second one is next to this
Dim Rng As Range ' working range
Dim C As Long ' WriteToClm
Dim Criteria() As String ' selected values from TriggerClm
Dim i As Integer ' index to Criteria()
' don't respond to changes of multiple cells such as Paste or Delete
If Target.CountLarge > 1 Then Exit Sub
' respond to changes in cells from row 2 to
' one cell below the last used row in the trigger column
Set Rng = Range(Cells(2, TriggerClm), _
Cells(Rows.Count, TriggerClm).End(xlUp).Offset(1))
If Not Application.Intersect(Rng, Target) Is Nothing Then
' intentionally all lower case because comparison
' is carried out case insensitive
' First item's date is in WriteToClm
Criteria = Split("impact assessed,ready for retesting", ",")
For i = UBound(Criteria) To 0 Step -1
If StrComp(Target.Value, Criteria(i), vbTextCompare) = 0 Then Exit For
Next i
' i = -1 if no match was found
If i >= 0 Then
C = Columns(WriteToClm).Column + i
Cells(Target.Row, C).Value = Date
End If
End If
End Sub
You can use something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("A:A"), Target)
If Not rng Is Nothing Then
For Each c in rng.cells
Select Case LCase(c.Value)
Case "impact assessed": c.Offset(0, 1).Value = Date
Case "ready": c.Offset(0, 2).Value = Date
End Select
Next c
End If
End Sub
FYI = Range(Target.Address) is the same (in this case) as Target - no need to get the address just to turn that back into a range.