Comment Used To Track Changes - excel

I have encountered a few issues with some code in VBA. I am trying to have the changes made to a cells on an excel sheet show up in comments on the cell the change was made to and I wish for these changes to be stored in a list so I can view them all later. I have tried lots of different pieces of code I have found to try and implement it into the code but none have worked.
Any ideas on how to get this to work?
Worksheet
The below code is what I am currently using
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Adding As Boolean, Finding As Boolean, Subtracting As Boolean
Dim f As Range, v
Select Case Target.Address(True, True)
Case "$A$4": Adding = True
Case "$C$4": Subtracting = True
Case "$E$4": Finding = True
Case Else: Exit Sub
End Select
v = Trim(Target.Value)
If Len(v) = 0 Then Exit Sub
Set f = Me.Range("C8").Resize(1000, 1).Find(v, lookat:=xlWhole)
If Adding Then
If f Is Nothing Then
'not found: add as new row
Set f = Me.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
f.Value = v
End If
f.Offset(0, 1).Value = f.Offset(0, 1).Value + 1
doDate f.Offset(0, 2)
Target.Value = ""
ElseIf Subtracting Then
If f Is Nothing Then
MsgBox v & " not found for subtraction!"
Else
f.Offset(0, 1).Value = f.Offset(0, 1).Value - 1
doDate f.Offset(0, 3)
Target.Value = ""
End If
Else 'finding
If Not f Is Nothing Then
f.EntireRow.Select
Target.Value = ""
Else
MsgBox v & " not found."
End If
End If
If Adding Or Subtracting Then Target.Select
End Sub
Sub doDate(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub
I have implemented a few formulas on the worksheet but don't see any reason why it would matter in this situation since they only track quantity of items with the same unique identifier.
I also tried some code that added comments to the cells as they were changed that worked but always returned the previous cell value as blank. It is not actually added into the current code though.
Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Target.ClearComments
Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & "By " & Environ("UserName")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target = "" Then
preValue = "a blank"
Else: preValue = Target.Value
End If
End Sub

By and large, the code below should do what you want. I marveled at your use of A4 and C4 to express addition and subtraction. As it is, whatever you change in those two cells, apart from clearing them, will result in a quantity of 1 being added or subtracted. I would have expected that a quantity must be entered there which is processed. If the quantity is fixed at 1 the system appears too elaborate.
Anyway, here's the code. I guess you'll be able to modify it to better suit your needs.
Private Sub Worksheet_Change(ByVal Target As Range)
' 038
Dim LookUp As Variant ' subject
Dim Action As Variant ' add = 1, subtract = -1, find = 2
Dim Fnd As Range ' Result of Find method
Dim Txt As String ' comment text
With Target
If (.Row <> 4) Or (.CountLarge > 1) Then Exit Sub
LookUp = Cells(4, "E").Value
On Error Resume Next
Action = Array(0, 1, 0, -1, 0, 2)(.Column)
End With
If Action And (LookUp <> "") Then
' C8 to end of column C
With Range(Cells(8, "C"), Cells(Rows.Count, "C").End(xlUp))
Set Fnd = .Find(LookUp, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows)
End With
End If
If Fnd Is Nothing Then
Select Case Action
Case -1
MsgBox """" & LookUp & """ not found.", vbInformation, "Can't subtract"
Action = -2
Case 2
MsgBox """" & LookUp & """ not found.", vbInformation, "No record"
Action = -2
Case Else
Set Fnd = Cells(Rows.Count, "C").End(xlUp).Offset(1)
Fnd.Value = LookUp
End Select
End If
With Fnd
If Abs(Action) <> 2 Then
With .Offset(0, 1)
If .Comment Is Nothing Then
.AddComment
Else
Txt = Chr(10)
End If
Txt = "Previous Qty = " & .Value & Chr(10) & _
"Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & _
"by " & Environ("UserName") & Txt
.Comment.Text Txt, 1, False
.Value = Val(.Value) + Action
With .Offset(0, 2)
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End With
ElseIf Action = 2 Then
.EntireRow.Select
End If
End With
If Action <> 2 Then Target.Select
End Sub

Related

Vlookup for multiple Ranges

The below code is for VLOOKUP result in same cell, which is working well, but now I also need VLOOKUP values for Range("K:L"), (R:S) and further.
My vlookup formula is this :
nx = Application.WorksheetFunction.VLookup(batch, Sheets("Batch Card REGISTER").Range("D:E"), 2, False)
Column Index no : 2
Result I need: If i type the Qty in Cl no 10, it will verify the value from the other sheet based on the 'batch'. The column index no for all the ranges is same i.e. 2
Example: If i type 100 in Cl no 10, it will verify in the "Batch Card Register" whether the value of the mentioned batch is 100 or not. If value is not 100 i have added a code so it will return the original value which is 90.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim check
Dim cl As Range
Dim mx As Double
Dim nx As Double
Dim batch
Dim rng As Range
Dim Rg As Range
ActiveSheet.Unprotect "FGIM#22"
For Each cl In Target.Cells
If Target.Column = 10 And Target.Offset(0, -3).Value = "Product_In" Then
Application.EnableEvents = False
batch = Target.Offset(0, -6)
Set Rg = Sheets("Batch Card REGISTER").Range("D:E")
nx = Application.WorksheetFunction.VLookup(batch, Sheets("Batch Card REGISTER").Range("D:E"), 2, False)
If Target.Value And nx <> Target.Value Then
MsgBox "NOTE: Value does not Match" & VBA.Constants.vbNewLine & "Orginal Value from Batch Card Register will be Restored", vbOKOnly, "ENTRY ERROR!"
Target.Value = nx
End If
Application.EnableEvents = True
End If
Verify entry in column J when "Dispatch" in is column G
If Target.Column = 10 And Target.Offset(0, -3).Value = "Dispatch" Then
Application.EnableEvents = False
batch = Target.Offset(0, -6)
Set rng = Sheets("FG Register").Columns("D:I")
mx = Application.WorksheetFunction.VLookup(Target.Offset(0, -6), Sheets("FG Register").Columns("D:I"), 6, False)
If Target.Value And mx < 0 Then
MsgBox "Value in Current Stock cannot exceed " & mx, vbOKOnly, "ENTRY ERROR!"
Target.Value = Target.Value + mx
End If
Application.EnableEvents = True
End If
If Target.Column = 10 Then
check = MsgBox("NOTE: CANNOT be edited after confirmation, Confirm the Entry?", vbYesNo, "Confirm Entry")
If check = vbYes Then
Range("A" & cl.Row & ":J" & cl.Row).Locked = True
Else
Range("C" & cl.Row & ":H" & cl.Row).Locked = False
End If
End If
Next cl
If Not Intersect(Target, Me.Range("A1:AA1000")) Is Nothing Then
ThisWorkbook.Save
End If
End Sub

Automatically add comment with cell edit history having no character limit

I am using the below code from this link
Need help
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'If (Target.Row > 3 And Target.Row < 155) Then Cells(Target.Row, "AT") = Now()
Const sRng As String = "A5:AQ155" ' change as required
Dim sOld As String
Dim sNew As String
Dim sCmt As String
Dim iLen As Long
Dim bHasComment As Boolean
With Target(1)
If Intersect(.Cells, Me.Range(sRng)) Is Nothing Then
Application.EnableEvents = True
Exit Sub
End If
sNew = .Text
sOld = .Text
.Value = sNew
Application.EnableEvents = True
sCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & Application.UserName & Chr(10) & "Previous Text :- " & sOld
If Target(1).Comment Is Nothing Then
.AddComment
Else
iLen = Len(.Comment.Shape.TextFrame.Characters.Text)
End If
With .Comment.Shape.TextFrame
.AutoSize = True
.Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt
End With
End With
End Sub
Sub Hide_Comments_in_Workbook_Completely()
'This macro hides the comments and comment indicators - users wont know there is a comment within the excel workbook
Application.DisplayCommentIndicator = xlNoIndicator
End Sub
The above code works fine only one problem I am facing.
It creates a history of 9 changes in 9 lines in comments if the changes exceeded or Total Character (with space) in comments is 268 more then the previous line is automatically erased.
Can anyone help me to overcome the above problem?
I want no bindings of changes or character input or line limits.
Thanks in advance and appreciate any help.
Characters is limited in the length of text you can address. You could instead delete and re-add the comment with the new text added.
This worked for me in testing:
Private Sub Worksheet_Change(ByVal Target As Range)
Const sRng As String = "A5:AQ155" ' change as required: must be a contiguous range
Dim c As Range, rng As Range, oldVals, newVals, newValsTgt, usr
Dim col As Long, rw As Long, txt As String, s As String
If Target.Areas.Count > 1 Then Exit Sub 'only handling single Area changes
Set rng = Application.Intersect(Target, Me.Range(sRng))
If rng Is Nothing Then Exit Sub
On Error GoTo haveError
Application.EnableEvents = False 'don't re-trigger event
newValsTgt = ToArray(Target) 'get current Target values
newVals = ToArray(rng) 'get current values for range of interest
Application.Undo 'restore previous values
oldVals = ToArray(rng) 'get pre-update values for range of interest
Target.Value = newValsTgt 'restore the Target range values
Application.EnableEvents = True
usr = Application.UserName
For rw = 1 To UBound(newVals, 1) 'loop over the new values
For col = 1 To UBound(newVals, 2)
If newVals(rw, col) <> oldVals(rw, col) Then 'was the content changed?
Set c = rng.Cells(rw, col)
s = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & _
" by " & usr & Chr(10) & _
"Previous Text :- " & oldVals(rw, col)
If c.Comment Is Nothing Then
c.AddComment s
Else
txt = c.Comment.Text
c.Comment.Delete
c.AddComment s & vbLf & txt
End If
c.Comment.Shape.TextFrame.AutoSize = True
End If
Next col
Next rw
Exit Sub 'normal exit
haveError:
Debug.Print "Error: " & Err.Description
Application.EnableEvents = True 'ensure events are back on
End Sub
'returns the value of both single cells and ranges as an array...
Function ToArray(rng As Range)
Dim rv
If rng.CountLarge = 1 Then
ReDim rv(1 To 1, 1 To 1)
rv(1, 1) = rng.Value
ToArray = rv
Else
ToArray = rng.Value
End If
End Function

how to use equal to and multiple Vlookup in single cell

I have created a multiselect dropdown for Cities in my sheet 1 and the postcodes associated with the dropdown is in sheet 2.
This is how my sheet 2 looks.
1.) User is allowed to select multiple cities from the dropdown. As soon as user selects the city, I want to show in one cell the selected city and the associated postcodes. For e.g. If user selects Sion and Dadar from the dropdown then just below the dropdown user should be able to see something like this.
With the help of Vlookup i am able to retrieve either one of the value and also not able to show in a single cell with equals to sign.
2.) Also I have used VBA code from the internet to have multiple select and remove. The code works fine but I want to make some changes in it. Like when user selects two cities the value gets populated in the dropdown cell separated by "comma". I want everytime the second value to go on next line but to remain in the same cell and also dynamically adjust the row height with leaving some margin from top and bottom. I am new to VBA and don't know how exactly to get it on next line.
This is how it currently looks.
But instead of above, I want it look like this
Here is the VBA code which i have used.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Me.Range("J2, K2,L2,M2,N2")
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If InStr(1, xValue1, xValue2 & ",") > 0 Then
xValue1 = Replace(xValue1, xValue2 & ", ", "") ' If it's in the middle with comma
Target.Value = xValue1
GoTo jumpOut
End If
If InStr(1, xValue1, ", " & xValue2) > 0 Then
xValue1 = Replace(xValue1, ", " & xValue2, "") ' If it's at the end with a comma in front of it
Target.Value = xValue1
GoTo jumpOut
End If
If xValue1 = xValue2 Then ' If it is the only item in string
xValue1 = ""
Target.Value = xValue1
GoTo jumpOut
End If
Target.Value = xValue1 & ", " & xValue2
End If
jumpOut:
End If
End If
Application.EnableEvents = True
End Sub
Select Formulas » Defined Names » Name Manager
Replace the Refers to: formula with the following formula:
=OFFSET(Lookups!$A$2,0,0,COUNTA(Lookups!$A:$A)-1)
You can now go nuts with adding and removing values from the Priority list and the dropdowns will have updated values with no additional effort!
To break down the OFFSET formula usage (using List_Priority as the example):
Lookups!$A$2: start at cell $A$2 on sheet named "Lookups" which is
the first value in the list
0: stay in that same row (so still at
$A$2)
0: stay in that same column (so, again, still at $A$2)
COUNTA(Lookups$A:$A)-1: count the number of cells in column A that
have values and then subtract 1 (the heading cell: “Priority”); grab
an area that is that tall, starting with the cell currently
“selected” ($A$2)
Add the Dependent Drop Down
On the DataEntry sheet, select cell E6.
On the Ribbon, click the Data tab, then click Data Validation..
From the Allow drop-down list, choose List.
In the Source box, type an equal sign and INDIRECT function,
referring to the first data cell in the Produce Type column: ...
Click OK.
Put code on Sheet Lookup
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("E6")) Is Nothing And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If Len(Target.Offset(1, 0)) = 0 Then ' (1,0) down direction (0,1) right
Target.Offset(1, 0) = Target ' (1,0) down direction (0,1) right
Else
Target.End(xlDown).Offset(1, 0) = Target ' (1,0) down direction (0,1) right
End If
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
For
Sion = 400022
You can use Vlookup formula
=VLOOKUP(Table1[Segments];Table1[Segments];1;FALSE)&" = "&VLOOKUP(Table1[Segments];Sheet2!A2:B4;2;FALSE)
I am not getting how to do it for multiselect. This works only when user select single option from the dropdown
Another solution. Change Sheet name and ranges and try:
Option Explicit
Sub test()
Dim strCitys As String
Dim rng As Range
Dim arr As Variant, strResults As Variant, City As Variant
With ThisWorkbook.Worksheets("Sheet1")
strCitys = .Range("A1").Value
Set rng = .Range("D1:E3")
strResults = ""
If strCitys <> "" Then
If InStr(1, strCitys, ",") = 0 Then
strResults = Application.VLookup(strCitys, rng, 2, False)
If Not IsError(strResults) Then
.Range("B1").Value = strCitys & "=" & strResults
Else
.Range("B1").Value = strCitys & "=" & "Missing Code"
End If
Else
For Each City In Split(strCitys, ",")
strResults = Application.VLookup(Trim(City), rng, 2, False)
If Not IsError(strResults) Then
If .Range("B1").Value = "" Then
.Range("B1").Value = Trim(City) & "=" & strResults
Else
.Range("B1").Value = .Range("B1").Value & vbNewLine & Trim(City) & "=" & strResults
End If
Else
If .Range("B1").Value = "" Then
.Range("B1").Value = Trim(City) & "=" & "Missing Code"
Else
.Range("B1").Value = .Range("B1").Value & vbNewLine & Trim(City) & "=" & "Missing Code"
End If
End If
Next City
End If
Else
.Range("B1").Clear
MsgBox "Please select city/ies."
End If
End With
End Sub
Results:

VBA Userform Listbox Conditional Logic Not Working as Intended

I have a Userform with a listbox for which I am using conditional logic to determine output values to the sheet of selected or non-selected items in the listbox. The issue is that when the Textbox (Tbl_AliasName) is blank, the code executes this:
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
But if Tbl_AliasName is not blank then the code does nothing, but it is supposed to do this:
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
I have used several variations of If statements, and non of which have worked.
Below is My Code:
Option Explicit
Public Tbl_AliasName As String
Tbl_AliasName = Trim(UserForm_Finder.txtConcat.Value)
Private Sub BtnConcat_Click()
Dim k As Long, lstbxRow As Long, LR As Long
lstbxRow = 1
'****************
'This if statement works perfectly
If (Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) _
And Tbl_AliasName = vbNullString Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf (UserForm_Finder.ListBx_TblsCols.ListCount = 0 And Tbl_AliasName <> vbNullString) Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
'(Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) And _
Exit Sub
End If
With UserForm_Finder.ListBx_TblsCols
For k = 0 To .ListCount - 1
'****************
This is where the problems begin
If .Selected(k) = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
End If
Next k
End With
End Sub
My goal is to do the following:
If a Textbox (Tbl_AliasName) is not blank and the user has selected one or more items in the listbox (ListBx_TbleCols) then concatenate the Tbl_AliasName to the selected items in the listbox
If Tbl_AliasName is blank, then use the value in Cells(2,1) to concatenate to the selected Items in the list box.
I have tried the following additions:
Dim LstBxItemSelected As Boolean
'This was placed in the for loop
LstBxItemSelected = True
'this was placed outside the for loop
If LstBxItemSelected = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
End If
Is there a better way to tell if items are selected, because I feel that the way I have it structured in my loop, the code will throw the error if everything isn't selected? Thank you in advance for any ideas, answers, or suggestions!
Note: The Listbox is populated by the click of another button on the userform which calls the following sub:
Sub FillLstBxCols()
Dim ListBx_Target As MSForms.ListBox
Dim rngSource As Range
Dim LR As Long
If Cells(2, 1).Value2 <> vbNullString Then
LR = Worksheets("New TRAX").Cells(Rows.Count, 2).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("New Trax").Range("A" & 2 & ":" & "B" & LR)
'Fill the listbox
Set ListBx_Target = UserForm_Finder.ListBx_TblsCols
With ListBx_Target
.RowSource = rngSource.Address
End With
End If
End Sub
Hard to say without sample data and expected results, but I think this is what you're looking for:
Private Sub btnConcat_Click()
Dim ws As Worksheet
Dim bSelected As Boolean
Dim sConcat As String
Dim i As Long, lRowIndex As Long
Set ws = ActiveWorkbook.Sheets("New TRAX")
lRowIndex = 1
bSelected = False
sConcat = Trim(Me.txtConcat.Text)
If Len(sConcat) = 0 Then sConcat = Trim(ws.Cells(2, "A").Value)
If Len(sConcat) = 0 Then
MsgBox "You must Search for a Table or Column first.", vbExclamation, "Error Encountered"
Exit Sub
End If
For i = 0 To Me.ListBx_TblsCols.ListCount - 1
If Me.ListBx_TblsCols.Selected(i) Then
If bSelected = False Then
bSelected = True
ws.Range("C2", ws.Cells(ws.Rows.Count, "C")).Clear 'clear previous concat results (delete this line if not needed)
End If
lRowIndex = lRowIndex + 1
ws.Cells(lRowIndex, "C").Value = sConcat & "." & Me.ListBx_TblsCols.List(i)
End If
Next i
If bSelected = False Then MsgBox "Must select at least one item from the list"
End Sub

WorksheetChange Event to Concatenate Row and First Letter of First Name + First Letter of Last Name

I think the code should be something like this, but I'm getting an error on this line where I am trying to handle the first and last names. Basically, I want to create a code in Column A, which is the first letter of the person's first name and first letter of the person's last name, concatenated with the row number. The row will be the active row (always Column A) and the first and last names will be stored in Column B.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
On Error GoTo ErrHandler
Application.EnableEvents = False
If Target.Column = 1 Then
Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
TV1 = Target.Offset(0, 0).FormulaR1C1
Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(R[" & "=ROW()" & "]C[1],1)&MID(R[" & "=ROW()" & "]C[1],FIND("" "",R[" & "=ROW()" & "]C[1],1)+1,1))"
TV2 = Target.Offset(0, 0).FormulaR1C1
Target.Offset(0, 0).Value = TV2 & "-" & TV1
End If
End Sub
I don't like to avoid dealing with more than a single cell as the Target. It isn't hard to deal with multiple cells.
After disabling events and performing your processing, you are not turning them back on again. You code will only run once without manually turning events back on.
If you are putting first and last names into column B, shouldn't the processing be subject to column B and not column A?
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo ErrHandler
Application.EnableEvents = False
Dim trgt As Range
For Each trgt In Intersect(Target, Target.Parent.UsedRange, Columns("B"))
trgt = StrConv(Trim(trgt.Value2), vbProperCase)
If CBool(InStr(2, trgt.Value2, Chr(32))) Then
trgt.Offset(0, -1) = _
UCase(Left(trgt.Value2, 1)) & _
UCase(Mid(trgt.Value2, InStr(1, trgt.Value2, Chr(32)) + 1, 1)) & _
Format(trgt.Row, "000")
End If
Next trgt
End If
ErrHandler:
Application.EnableEvents = True
End Sub
I've added some trim and proper-case conversion to auto-correct the values being typed into column B.
In the following image, I copied the names from G5:G8 and pasted them into B2:B5.
I would do this differently. Why write formulas when you can do it simply in VBA?
I've made some annotations to your original code also:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
Application.EnableEvents = False
' No error handler in your code
'On Error GoTo ErrHandler
' don't need to check if column 1 since we already did that and exited the sub if it was not
' If Target.Column = 1 Then
'Target.Offset(0,0) = Target
'Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
'TV1 = Target.Offset(0, 0).FormulaR1C1
'Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(R[" & "=ROW()" & "]C[1],1)&MID(R[" & "=ROW()" & "]C[1],FIND("" "",R[" & "=ROW()" & "]C[1],1)+1,1))"
'TV2 = Target.Offset(0, 0).FormulaR1C1
'Target.Offset(0, 0).Value = TV2 & "-" & TV1
'Just do the creation in VB
With Target
.Value = .Row & Left(.Offset(0, 1), 1) & Left(Split(.Offset(0, 1))(1), 1)
End With
'If you have more than two space-separated words in the name, then something like
Dim V As Variant
With Target
V = Split(.Offset(0, 1))
.Value = .Row & Left(V(0), 1) & Left(V(UBound(V)), 1)
End With
'Don't forget to reenable events
Application.EnableEvents = True
End Sub
Also, since the names are in Column B, why are you testing for a change in Column A? There could be reasons, but if there are not, it might be smoother to check for changes in column B.
I figured it out!!
If Target.Column = 1 Then
Target.Offset(0, 0).FormulaR1C1 = "=ROW()"
TV1 = Target.Value
Target.Offset(0, 0).FormulaR1C1 = "=UPPER(LEFT(RC[1],1)&MID(RC[1],FIND("" "",RC[1],1)+1,1))"
TV2 = Target.Value
Target.Value = TV2 & "-" & TV1
End If

Resources