Worksheet Change Event

[sspatriots]

I have this subject worksheet change event code that is pretty much a hack that I kept working at until something worked. I've tried to do the best I can at adding commented text to explain what is going on in the code. I'm certain there is a lot in here that could be done away with. The issue that I'm having with this code is that one of the users of the file that this code is in keeps losing his focus when working in the file. I've tried and tried to replicate what he is doing and I never lose focus. I'm hoping someone can take a peak at this and give me some pointers on any fundamental things I may be doing wrong. I realize there are a lot of different targeted ranges, but I don't know of another way to get around it.


Thanks, SS

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sSheetName As String
Dim r As Long

'*********START - DECLARED VARIABLES FOR ADDING ITEMS TO DROP-DOWN LIST*********
Dim cl As Range
Dim ws As Worksheet
Dim str As String
Dim i As Integer
Dim rngDV As Range
Dim Rng As Range
Dim lCol As Long
Dim myRsp As Long
Dim My_Value As String
Dim My_HValue As String
Dim strList As String
'*********STOP - DECLARED VARIABLES FOR ADDING ITEMS TO DROP-DOWN LIST*********

'*********START - THIS CODE TARGETS COLUMN "J" TO ALLOW SELECTING MORE THAN ONE ITEM FROM A DROP-DOWN LIST WITH THE SELECTIONS BEING COMMA SEPARATED*********
On Error GoTo Exitsub
If Not Intersect(Target, Range("J:J")) Is Nothing Then
  If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
  Else: If Target.Value = "" Then GoTo Exitsub Else
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
      If Oldvalue = "" Then
        Target.Value = Newvalue
      Else
        If InStr(1, Oldvalue, Newvalue) = 0 Then
            Target.Value = Oldvalue & ", " & Newvalue
      Else:
        Target.Value = Oldvalue
      End If
    End If
  End If
End If
Application.EnableEvents = True
'*********STOP - THIS CODE TARGETS COLUMN "J" TO ALLOW SELECTING MORE THAN ONE ITEM FROM A DROP-DOWN LIST WITH THE SELECTIONS BEING COMMA SEPARATED*********

'*********START - THIS CODE TARGETS COLUMN "M" TO ALLOW SELECTING MORE THAN ONE ITEM FROM A DROP-DOWN LIST WITH EACH SELECTION STARTING A NEW LINE IN THE CELL*********
    On Error GoTo Exitsub
    If Not Intersect(Target, Range("M:M")) Is Nothing Then
      If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        GoTo Exitsub
      Else: If Target.Value = "" Then GoTo Exitsub Else
        Application.EnableEvents = False
        Newvalue = Target.Value
        Application.Undo
        Oldvalue = Target.Value
          If Oldvalue = "" Then
            Target.Value = Newvalue
          Else
            If InStr(1, Oldvalue, Newvalue) = 0 Then
                Target.Value = Oldvalue & vbNewLine & Newvalue
          Else:
            Target.Value = Oldvalue
          End If
        End If
      End If
    End If
    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
'*********STOP - THIS CODE TARGETS COLUMN "M" TO ALLOW SELECTING MORE THAN ONE ITEM FROM A DROP-DOWN LIST WITH EACH SELECTION STARTING A NEW LINE IN THE CELL*********



'*********START - THIS CODE TARGETS COLUMNS "E", "G" THRU "J", "M" AND "O" THRU "Q" TO TRACK CHANGES TO THE "LogDetails" WORKSHEET. *********
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("E:E,G:J,M:M,O:Q")) Is Nothing Then Exit Sub

    oldAddress = Target.Address

    sSheetName = ActiveSheet.Name
    r = ActiveCell.Row

    If ActiveSheet.Name <> "LogDetails" Then

    Application.EnableEvents = False

'*********START - THIS CODE POPULATES Columns A through E on the "LogDetails" worksheet*********
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name & " - " & Target.Address(0, 0)
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Oldvalue
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Target.Value
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Environ("username")
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Now
'*********STOP - THIS CODE POPULATES Columns A through E on the "LogDetails" worksheet*********

'*********START - THIS CODE POPULATES Columns G through P on the "LogDetails" worksheet; THIS INFORMATION IS EVENTUALLY SENT OUT IN A PDF FORMAT ONCE ALL PO BLOCK HISTORY UPDATES ARE COMPLETE*********
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = ActiveSheet.Range("A" & r)  'Column D Source WS to "PO#" column G on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = ActiveSheet.Range("E" & r)  'Column E Source WS to "Supplier" column H on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 8).Value = ActiveSheet.Range("G" & r)  'Column G Source WS to "By" column I on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 9).Value = ActiveSheet.Range("H" & r)  'Column H Source WS to "Ship" to column J on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 10).Value = ActiveSheet.Range("I" & r) 'Column I Source WS to "Description(Excluding Job List EQPT)" column K on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 11).Value = ActiveSheet.Range("J" & r) 'Job List Equipment column L on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 12).Value = ActiveSheet.Range("M" & r) 'Column M Source WS to "DEM Job Name2" column M on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 13).Value = ActiveSheet.Range("O" & r) 'Column O Source WS to "DEM Customer" column N on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 14).Value = ActiveSheet.Range("P" & r) 'Column P Source WS to "Notes:" column O on LogDetails tab
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 15).Value = ActiveSheet.Range("Q" & r) 'Column Q Source WS to "Date Received:" column P on LogDetails tab
'*********STOP - THIS CODE POPULATES Columns G through P on the "LogDetails" worksheet; THIS INFORMATION IS EVENTUALLY SENT OUT IN A PDF FORMAT ONCE ALL PO BLOCK HISTORY UPDATES ARE COMPLETE*********

'*********START - ADD THE BACK LINK*********
    Sheets("LogDetails").Hyperlinks.Add Anchor:=Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5), Address:="", _
    SubAddress:="'" & sSheetName & "'!" & oldAddress, TextToDisplay:=oldAddress
'*********STOP - ADD THE BACK LINK*********

'*********STOP - THIS CODE TARGETS COLUMNS "E", "G" THRU "J", "M" AND "O" THRU "Q" TO TRACK CHANGES TO THE "LogDetails" WORKSHEET. *********

    Sheets("LogDetails").Columns("A:E").AutoFit
    Application.EnableEvents = True


'*********START - THIS CODE ENABLES ADDING ITEMS TO DROP-DOWN LIST*********
    On Error Resume Next

    Set ws = Worksheets("Drops")

    If Target.Row > 1 Then
        On Error Resume Next
        Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)

        On Error GoTo 0

        If rngDV Is Nothing Then Exit Sub

        If Intersect(Target, rngDV) Is Nothing Then Exit Sub

        str = Target.Validation.Formula1
        str = Right(str, Len(str) - 1)

        On Error Resume Next
        Set Rng = ws.Range(str)

        On Error GoTo 0
        If Rng Is Nothing Then Exit Sub

        If Application.WorksheetFunction _
            .CountIf(Rng, Target.Value) Then
            Exit Sub

    Else

        My_Value = Target.Value 'Added, SPS, 09/26/22

        My_HValue = Target.Offset(2 - Target.Row).Value 'Added, SPS, 10/04/22

        myRsp = MsgBox("Add '" & My_Value & "' to the '" & My_HValue & "' drop down list?", _
            vbQuestion + vbYesNo + vbDefaultButton1, _
            "New Item -- not in drop down")

        If myRsp = vbYes Then
            lCol = Rng.Column
            i = ws.Cells(Rows.Count, lCol).End(xlUp).Row + 1
            ws.Cells(i, lCol).Value = Target.Value

            strList = ws.Cells(1, lCol).ListObject.Name

            With ws.ListObjects(strList).Sort
                .SortFields.Clear
                .SortFields.Add _
                    Key:=Cells(2, lCol), _
                    SortOn:=xlSortOnValues, _
                    Order:=xlAscending
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

            With ws.ListObjects(strList)
                .Resize .DataBodyRange.CurrentRegion
            End With
        End If
    End If
End If
End If
'*********STOP - THIS CODE ENABLES ADDING ITEMS TO DROP-DOWN LIST*********

End Sub

 

[6StringJazzer]

one of the users...keeps losing his focus

What specifically do you mean by that?

 

[sspatriots]

What specifically do you mean by that?

Sorry, I"m sure I'm not using the right lingo here for what's happening. Basically, if you look at columns "J" and "M" in the code you will see that they are set up so the user can select more than one item from a drop-down list. This code allows the user to do this. However, this one user can be chugging along in the spreadsheet and then all of a sudden he when he selects a cell in either of those columns, he now longer has the ability to select more than one item. I hope this makes sense, because it is hard to explain. Thanks, Steve