Basically, I have a rather large (and growing) sheet of position details and I'm looking to build in a sub routine that, once a position number is entered into the relevant cell, will auto-populate the corresponding cells in the row. VLOOKUP would do the trick nicely except, when a position has multiple lines, it returns the earliest set of details--I need it to return the latest.
I can produce the answer I need using a LOOKUP function , but I can't seem to translate the function across to VBA.
Example lookup function:
LOOKUP(D17,1/($D$2:$D$10=D17),E2:E10)
This is what I have so far
Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 4 Then
actionrow = Target.Row
resulte = Application.WorksheetFunction.Lookup(2, 1 / Range("D2:D10") = Target.Value, Range("E2:E10"))
If Target.Value <> "" Then
Range("E" & actionrow).formula = resulte
End If
End If
End Sub
I think that looking at column D for a matching value with the Range.Find method would do. Start at the Target cell and use the SearchDirection:=xlPrevious option. Something will always be found. If the row it is found is not the same row as Target then use the value in column E to populate the cell right of Target.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Columns(4), Target) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = True
Dim trgt As Range, lastrw As Long
For Each trgt In Intersect(Columns(4), Target)
lastrw = Columns(4).Find(what:=trgt.Value, after:=trgt, _
lookat:=xlWhole, SearchDirection:=xlPrevious).Row
Debug.Print lastrw
If lastrw <> trgt.Row Then
trgt.Offset(0, 1) = Cells(lastrw, trgt.Column + 1).Value
End If
Next trgt
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
This should survive pasting multiple values into column D.
You can use .Find function with parameter SearchDirection:=xlPrevious
For case where you are searching word "AC" in a row 4:
Set FindCell = sh_wb_SF.Range("4:4").Find(What:="AC", LookIn:=xlValues, SearchDirection:=xlPrevious)
If FindCell Is Nothing Then
MsgBox ("Ooooooopppps")
End If
Related
I wrote the code below to clear the cell in column D only if the value of the cell in in the corresponding row of column B changes to a value that is part of a specific list/range (B118:B124). If I change the cell in B to any value that is not part of that list, the cell in the corresponding row in D will not clear (that is what I want).
The code below works fine, except, if for example I want to delete 5 (adjacent) cells in column B at the same time, I get runtime error 13. Same is the case if I enter a new value in the first of the deleted/blank cells and then try to auto fill it down to the rest of deleted/blank cells. Basically, the code below seems to not work if I want to change multiple cells in B at the same time (autofill,...). If I only delete/change one cell (in B) at a time, it works just fine. Any help would be greatly appreciated. Thanks.
Private Sub Worksheet_Change (ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
If Application.WorksheetFunction.CountIf(Range("B118:B124"), Target) Then
Range("D" & Target.Row).ClearContents
End If
End If
End Sub
I think the issue is that COUNTIF is expecting a singular value, not a range containing values. Try this instead:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each cell In Range(Target.Address)
If Application.WorksheetFunction.CountIf(Range("B118:B124"), cell) Then
Range("D" & cell.Row).ClearContents
End If
Next cell
End If
End Sub
EDIT: Updated answer with everyone's contributions:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each cell In Target
If Not Intersect(cell, Range("B:B")) Is Nothing Then
If Application.WorksheetFunction.CountIf(Range("B118:B124"), cell) Then
Application.EnableEvents = False
Range("D" & cell.Row).ClearContents
Application.EnableEvents = True
End If
End If
Next cell
End If
End Sub
When selecting a range, you must process each individually in this case. Loop the range in target and done.
Private Sub Worksheet_Change(ByVal Target As Range)
For Each cell In Target
If Not Intersect(cell, Range("B:B")) Is Nothing Then
If Application.WorksheetFunction.CountIf(Range("B118:B124"), cell) Then
Range("D" & cell.Row).ClearContents
End If
End If
Next
End Sub
I need to build a linked search function in VBA that also auto-updates after you enter data into the given search fields. I have been able to do this successfully with the following sections of code:
Autofilter search - in a standard module
Code:
Sub FilterTo1Criteria()
With Sheet3
If Range("A3") <> vbNullString Then
.AutoFilterMode = False
.Range("A6:J1015").AutoFilter
.Range("A6:J1015").AutoFilter Field:=1, Criteria1:=Range("A3")
Else
Selection.AutoFilter
End If
End With
End Sub
Sheet change/auto-update - This is in a worksheet module
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$3" Then
Application.EnableEvents = False
FilterTo1Criteria
Application.EnableEvents = True
End If
End Sub
However, within the sheet change page, I need cells A3:J3 to be the criteria, but I also need the auto search function to work if only A3 and D3 are filled in, or if just A3 is filled in (D3 is blank), or if just D3 is filled in (A3 is blank), but I'm having issues trying to compound the code to get this effect. How much more complicated will I have to make it? Are there some examples that someone is aware of that I can look at to glean some information from? It's hard to find any...
A slicer with a pivot table is a potential way to go, but I think some people downstream are using Excel 2003 and I don't think the slicer works back that far.
Thanks in advance!
For the function to work if either A3 or D3 are not empty, then you can concatenate the two cells and compare that to vbNullString.
For the multiple filters, you can use a loop to set them all.
eg:
Sub FilterTo1Criteria()
Dim i As Long
With Sheet3
If Range("A3") & Range("D3") <> vbNullString Then
.AutoFilterMode = False
.Range("A6:J1015").AutoFilter
For i = 1 To 10
.Range("A6:J1015").AutoFilter Field:=i, Criteria1:=Cells(3, i)
Next i
Else
Selection.AutoFilter
End If
End With
End Sub
Edit:
It looks like you wanted to set the filters as the criteria cells were filled, rather than all at once. Try this instead:
Sub FilterTo1Criteria()
Dim i As Long
With Sheet3
.AutoFilterMode = False
.Range("A6:J1015").AutoFilter
For i = 1 To 10
If .Cells(3, i) <> vbNullString Then
.Range("A6:J1015").AutoFilter Field:=i, Criteria1:=.Cells(3, i)
End If
Next i
End With
End Sub
and for the new worksheet change sub:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$A$3:$J$3")) Is Nothing Then
Application.EnableEvents = False
FilterTo1Criteria
Application.EnableEvents = True
End If
End Sub
This will add or remove filters as you add or remove criteria (row 3).
I've seen how to say "Is cell x in range y" but since I'm using VLookup I'm not sure how to reconcile the two.
Basically, the code below does a lookup on a table that contains tips and then displays them in a specified cell. It works great. What I would like to do is specify an entire range of cells in the lookup table, then if the user selects any cell within that range the tip is displayed. As it stands, if I have a large area of say 10 cells I have to create 10 duplicate entries in the lookup table (one for each cell).
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cellTitle As Range
Set cellTitle = Range("J2")
Dim cellTip As Range
Set cellTip = Range("J3")
If Target.Address = "$J$3:$K$5" Or Target.Address = "$J$2:$K$2" Or Target.Address = "$K$1" Then
'leave existing content in case user wants to copy tip
Else
Range("K1").Value = Target.Address
Title = Application.VLookup(Target.Address, Sheets("Settings").Range("TipsDashboard"), 2, False)
If Not IsError(Title) Then
Tip = Application.VLookup(Target.Address, Sheets("Settings").Range("TipsDashboard"), 3, False)
cellTitle.Value = Title
cellTip.Value = Tip
Else
cellTitle.Value = "Tips & Instructions"
cellTip.Value = "Try selecting various fields to get dynamic tips or instructions in this space."
End If
End If
End Sub
Here is a sample of my lookup table:
You'll notice there are ranges here, but they are merged cells.
edited: made so that it's possible to associate different cells in active sheet to the same range value in "cell" column of" Settings" sheet
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim cellTitle As Range, cellTip As Range, found As Range
Set cellTitle = Range("J2")
Set cellTip = Range("J3")
If target.address = "$J$3:$K$5" Or target.address = "$J$2:$K$2" Or target.address = "$K$1" Then
'leave existing content in case user wants to copy tip
Else
Range("K1").Value = target.address
Set found = GetCell(target, Sheets("Settings").Range("TipsDashboard").Columns(1))
If Not found Is Nothing Then
cellTitle.Value = found.Offset(, 1)
cellTip.Value = found.Offset(, 2)
Else
cellTitle.Value = "Tips & Instructions"
cellTip.Value = "Try selecting various fields to get dynamic tips or instructions in this space."
End If
End If
End Sub
Function GetCell(target As Range, sourceRng As Range) As Range
Dim cell As Range, cell2 As Range
With target
For Each cell In sourceRng.SpecialCells(xlCellTypeConstants, xlTextValues)
Set cell2 = GetRangeFromAddress(.Parent, cell.Value)
If Not cell2 Is Nothing Then
If Not Intersect(.cells, cell2) Is Nothing Then
Set GetCell = cell
Exit Function
End If
End If
Next cell
End With
End Function
Function GetRangeFromAddress(sht As Worksheet, address As String) As Range
On Error Resume Next
Set GetRangeFromAddress = sht.Range(address)
On Error GoTo 0
End Function
I'm having troubles with a VBA code: There's an Excel sheet (Sheet1) that contains two essential columns (last & first name)
What I am trying to do is, that whenever you add another last and first name to the list, both of them automatically get concatenated in another sheet and form a new list (start position for that list is Sheet11.Range("AB3"), on position AB2 is the list title "Clients").
My code therefore was entered in Sheet1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tmp As Range
For Each tmp In Sheet1.Range("C4:C100")
If tmp.Value <> "" And tmp.Offset(0, 1).Value <> "" Then
Sheet11.Cells(Cells(Rows.Count, "AB").End(xlUp).Row + 1, "AB").Value = tmp.Value & " " & tmp.Offset(0, 1).Value
End If
Next tmp
End Sub
Unfortunately, as soon as I enter first & last names while this code is active, the concatenated names are not listed one after another, but the last name in the list replaces the list title in AB2.
I guess the problem lies somewhere within the loop process, but I can't seem to figure out the logic behind it. I'd be thankful for any suggestions to solve that problem!
The problem is that the following instruction
Sheet11.Cells(Cells(Rows.Count, "AB").End(xlUp).Row + 1, "AB").Value
returns the same cell each time the loop is repeated. You can replace this whole line for example by this:
Range("AB" & tmp.Row).Value = tmp.Value & " " & tmp.Offset(0, 1).Value
Whenever you use a Worksheet_Change event macro to change the values of cell on the same worksheet, you need to turn off event handling or the value change will trigger a new event and the Worksheet_Change will try to run on top of itself. This also holds true for other worksheets that contain a Worksheet_Change unless you want the change in value to force the event. Similarly, the Target can represent more than a single cell (e.g. a paste operation) so you need to deal with the individual cells in the Intersect, not the Intersect as a whole.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B:C")) Is Nothing Then
On Error GoTo bm_Safe_exit
Application.EnableEvents = False
Dim bc As Range
For Each bc In Intersect(Target, Columns("B:C"))
Sheet11.Cells(bc.Row, "AB") = _
Join(Array(Cells(bc.Row, "B").Value2, Cells(bc.Row, "C").Value2))
Next bc
End If
bm_Safe_exit:
Application.EnableEvents = True
End Sub
I've used the Join Function as the string concatenation mechanism. While any character can be supplied as a connector in a Join, the default is a space.
I suggest a faster Change event - you don't need to loop over all rows for every update
This will add new entries and update existing ones:
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .CountLarge = 1 And .Row >= 3 And (.Column = 3 Or .Column = 4) Then
Dim cel As Range
Set cel = Cells(.Row, 3)
If Len(cel) > 0 And Len(cel.Offset(0, 1)) > 0 Then
Worksheets("Sheet11").Range("AB" & .Row) = cel & " " & cel.Offset(0, 1)
End If
End If
End With
End Sub
I have a VBA macro that validates user entered data (I didn't use data validation/conditional formatting on purpose).
I am using Worksheet_Change event to trigger the code, the problem I am facing now is, when there are row changes. I don't know whether it is a deleting / inserting rows.
Is there anyway to distinguish between those two?
You could define a range name such as
RowMarker =$A$1000
Then this code on your change event will store the position of this marker against it's prior position, and report any change (then stores the new position)
Private Sub Worksheet_Change(ByVal Target As Range)
Static lngRow As Long
Dim rng1 As Range
Set rng1 = ThisWorkbook.Names("RowMarker").RefersToRange
If lngRow = 0 Then
lngRow = rng1.Row
Exit Sub
End If
If rng1.Row = lngRow Then Exit Sub
If rng1.Row < lngRow Then
MsgBox lngRow - rng1.Row & " rows removed"
Else
MsgBox rng1.Row - lngRow & " rows added"
End If
lngRow = rng1.Row
End Sub
Try this code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lNewRowCount As Long
ActiveSheet.UsedRange
lNewRowCount = ActiveSheet.UsedRange.Rows.Count
If lOldRowCount = lNewRowCount Then
ElseIf lOldRowCount > lNewRowCount Then
MsgBox ("Row Deleted")
lOldRowCount = lNewRowCount
ElseIf lOldRowCount < lNewRowCount Then
MsgBox ("Row Inserted")
lOldRowCount = lNewRowCount
End If
End Sub
Also add this in the ThisWorkBook module:
Private Sub Workbook_Open()
ActiveSheet.UsedRange
lOldRowCount = ActiveSheet.UsedRange.Rows.Count
End Sub
And then this in its own module:
Public lOldRowCount As Long
The code assumes you have data in row 1. Note the very first time you run it you make get a false result, this is because the code needs to set the lRowCount to the correct variable. Once done it should be okay from then on in.
If you don't want to use the Public variable and worksheet open event then you could use a named range on your worksheet somewhere and store the row count (lRowCount) there.
After searching for a bit decided to solve it myself.
In your Worksheet module (e.g. Sheet1 under Microsoft Excel Objects in VBA Editor) insert the following:
Private usedRowsCount As Long 'use private to limit access to var outside of sheet
'Because select occurs before change we can record the current usable row count
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
usedRowsCount = Target.Worksheet.UsedRange.rows.count 'record current row count for row event detection
End Sub
'once row count recorded at selection we can compare the used row count after change occurs
'with the Target.Address we can also detect which row has been added or removed if you need to do further mods on that row
Private Sub Worksheet_Change(ByVal Target As Range)
If usedRowsCount < Target.Worksheet.UsedRange.rows.count Then
Debug.Print "Row Added: ", Target.Address
ElseIf usedRowsCount > Target.Worksheet.UsedRange.rows.count Then
Debug.Print "Row deleted: ", Target.Address
End If
End Sub
Assumption: That "distinguish the two" means to distinguish adding/deleting a row from any other type of change. If you meant, how to tell if the change was an add row OR delete row, then ignore my answer below.
In the case of inserting or deleting a row, the target.cells.count will be all the cells in the row. So you can use this If statement to capture it. Notice I use cells.columns.count since it might be different for each file. It will also trigger if the user selects an entire row and hits "delete" (to erase the values) so you'll need to code a workaround for that, though...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count = Cells.Columns.Count Then
MsgBox "Row added or deleted"
End If
End Sub
Some of what your end purpose of distinguishing between insertions and deletions ends up as will determine how you want to proceed once an insertion or deletion has been identified. The following can probably be cut down substantially but I have tried to cover every possible scenario.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim olr As Long, nlr As Long, olc As Long, nlc As Long
With Target.Parent.Cells
nlc = .Find(what:=Chr(42), after:=.Cells(1), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
nlr = .Find(what:=Chr(42), after:=.Cells(1), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.Undo 'undo the last change event
olc = .Find(what:=Chr(42), after:=.Cells(1), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
olr = .Find(what:=Chr(42), after:=.Cells(1), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.Repeat 'redo the last change event
End With
If nlr <> olr Or nlc <> olc Then
Select Case nlr
Case olr - 1
Debug.Print "One (1) row has been deleted"
Case Is < (olr - 1)
Debug.Print (olr - nlr) & " rows have been deleted"
Case olr + 1
Debug.Print "One (1) row has been inserted"
Case Is > (olr + 1)
Debug.Print (nlr - olr) & " rows have been inserted"
Case olr
Debug.Print "No rows have been deleted or inserted"
Case Else
'don't know what else could happen
End Select
Select Case nlc
Case olc - 1
Debug.Print "One (1) column has been deleted"
Case Is < (olc - 1)
Debug.Print (olc - nlc) & " columns have been deleted"
Case olc + 1
Debug.Print "One (1) column has been inserted"
Case Is > (olc + 1)
Debug.Print (nlc - olc) & " columns have been inserted"
Case olc
Debug.Print "No columns have been deleted or inserted"
Case Else
'don't know what else could happen
End Select
Else
'deal with standard Intersect(Target, Range) events here
End If
bm_Safe_Exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Essentially, this code identifies the last cell column-wise and the last cell cell row-wise. It then undoes the last operation and checks again. Comparing the two results allows it to determine whether a row/column has been inserted/deleted. Once the four measurements have been taken, it redoes the last operation so that any other more standard Worksheet_Change operations can be processed.
There are two a bit another approaches both based on the following template.
Define a module or class module variable of Range type.
“Pin” a special range by assigning it to the variable using absolute address and save its address or size (it depends on approach).
To determine a subtype of user action manipulate with the variable in a sheet change event handler.
In the first approach the whole range of interest is assigned to the variable and range's size is saved. Then in a sheet change event handler the following cases must be processed:
an exception occurs when accessing Address property => the pinned range is no longer exist;
the address of changed cell is below then pinned range => an insertion was => update the variable
a new size of the pinned range is different from saved (smaller => something was deleted, bigger => something was inserted).
In the second approach a “marker” range is assigned to the variable (see example below) and the range address is saved in order to determine movements or shifts in any direction. Then in a sheet change event handler the following cases must be processed::
an exception occurs when accessing Address property => the pinned “marker” range is no longer exist;
the address of changed cell is below then "marker" range => an insertion was => update the variable
there is a difference in any direction, i.e. abs(new_row - saved_row) > 0 or abs(new_col-saved_col) > 0 => the pinned range was moved or shifted.
Pros:
User-defined name is not used
UsedRange property is not used
A pinned range is updated accordingly to user actions instead of assumption that a user action will not occur below 1000-th row.
Cons:
The variable must be assigned in a workbook open event handler in order to use it in a sheet change event handler.
The variable and a WithEvents-variable of object must be assigned to Nothing in a workbook close event handler in order to unsubscribe form the event.
It is impossible to determine sort operations due to they change value of range instead of exchange rows.
The following example shows that both approaches could work. Define in a module:
Private m_st As Range
Sub set_m_st()
Set m_st = [$A$10:$F$10]
End Sub
Sub get_m_st()
MsgBox m_st.Address
End Sub
Then run set_m_st (simply place a cursor in the sub and call Run action) to pin range $A$10:$F$10. Insert or delete a row or cell above it (don't confuse with changing cell(s) value). Run get_m_st to see a changed address of the pinned range. Delete the pinned range to get "Object required" exception in get_m_st.
Capture row additions and deletions in the worksheet_change event.
I create a named range called "CurRowCnt"; formula: =ROWS(Table1).
Access in VBA code with:
CurRowCnt = Evaluate(Application.Names("CurRowCnt").RefersTo)
This named range will always hold the number of rows 'after' a row(s) insertion or deletion. I find it gives a more stable CurRowCnt than using a global or module level variable, better for programming, testing and debugging.
I save the CurRowCnt to a custom document property, again for stability purposes.
ThisWorkbook.CustomDocumentProperties("RowCnt").Value = Evaluate(Application.Names("CurRowCnt").RefersTo)
My Worksheet_Change Event structure is as follows:
Dim CurRowCnt as Double
CurRowCnt = Evaluate(Application.Names("CurRowCnt").RefersTo)
Select Case CurRowCnt
'' ########## ROW(S) ADDED
Case Is > ThisWorkbook.CustomDocumentProperties("RowCnt").Value
Dim r As Range
Dim NewRow as Range
ThisWorkbook.CustomDocumentProperties("RowCnt").Value = _
Evaluate(Application.Names("CurRowCnt").RefersTo)
For Each r In Selection.Rows.EntireRow
Set NewRow = Intersect(Application.Range("Table1"), r)
'Process new row(s) here
next r
'' ########## ROW(S) DELETED
Case Is < ThisWorkbook.CustomDocumentProperties("RowCnt").Value
ThisWorkbook.CustomDocumentProperties("RowCnt").Value = _
Evaluate(Application.Names("CurRowCnt").RefersTo)
'Process here
'' ########## CELL CHANGE
'Case Is = RowCnt
'Process here
'' ########## PROCESSING ERROR
Case Else 'Should happen only on error with CurRowCnt or RowCnt
'Error msg here
End Select