Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rowNum As Integer
rowNum = InputBox("Enter Row Number where you want to add a row:", Title:="Add New Row")
If Len(rowNum) = 0 Then
MsgBox ("You have not entered a row number.")
Exit Sub
End If
Rows(rowNum).Insert Shift:=xlDown
Cells(rowNum, 1).Select
'UserForm1.Show
With Application.ActiveSheet
'Dim Valid As Hyperlink
.Hyperlinks.Add _
Anchor:=.Cells(rowNum, Range("AA1:AA5000").Column), _
Address:="", _
SubAddress:=.Cells(rowNum, Range("AA1:AA5000").Column).Address, _
ScreenTip:="Edit This Row", _
TextToDisplay:="Edit"
.Hyperlinks.Add _
Anchor:=.Cells(rowNum, Range("AB1:AB5000").Column), _
Address:="", _
SubAddress:=.Cells(rowNum, Range("AB1:AB5000").Column).Address, _
ScreenTip:="Delete This Row", _
TextToDisplay:="Delete"
End With
UserForm1.Show
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
'Author - Jason Kearney, 2/23/18
Private Sub ResetEvents()
'Run this if Worksheet_Change does not end before resetting events.
Application.EnableEvents = True
MsgBox "Events Reset.", vbOKOnly
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim KeyCells As Range
Application.EnableEvents = False
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("N3:N5000")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
'Identify the current Row
Dim ThisRow As Integer
ThisRow = Target.row
Dim ThisCol As Integer
ThisCol = Target.Column
Dim ThisLevel As Integer
Dim ThisAction As String
Dim ThisItemName As String
Dim FindColName As String
'Record the value for changing
ThisAction = Target.Text
'Find the current BOM Level
Dim ShowErrs As Boolean
'First Pass - Notify if errors.
ShowErrs = True
ThisLevel = RowBOMLevel(ThisRow, ShowErrs)
Dim CursorRow As Integer
CursorRow = ThisRow + 1
'Find the "Comments" column
Dim CommentsCol As Integer
Dim UserComments As String
Dim AffectedComment As String
Dim ItemNameCol As Integer
FindColName = "Comments"
CommentsCol = FindColumnByName(FindColName)
If CommentsCol <> -1 Then
'Prompt user for change comments
If UCase(ThisAction) <> "CHANGE" Then
UserComments = InputBox("Reason for Changes:", "Add Comments...")
If UserComments = vbNullString Then
Cells(ThisRow, ThisCol).Value = ""
MsgBox "Error: Please Reset Action Manually", vbOKOnly
GoTo CancelledChange
End If
Else
UserComments = ""
End If
Cells(ThisRow, CommentsCol).Value = UserComments
'Identify changed item-name for marking comments of affected rows
FindColName = "Part Number"
ItemNameCol = FindColumnByName(FindColName)
If ItemNameCol <> -1 Then
ThisItemName = Cells(ThisRow, ItemNameCol).Text
If UCase(ThisAction) = "REMOVE" Then
AffectedComment = "Parent BOM removed: " & ThisItemName
Else
AffectedComment = ""
End If
End If
End If
'Second pass and beyond, exceptions occur upon end conditions met
ShowErrs = False
'Update all sub-level BOM items to the same status
Do While (RowBOMLevel(CursorRow, ShowErrs) > ThisLevel And RowBOMLevel(CursorRow, ShowErrs) > -1)
'Convert value to match
Cells(CursorRow, Target.Column).Value = Target.Text
'Mark/Unmark Comments If REMOVEd/CHANGEd
If (CommentsCol <> -1 And ItemNameCol <> -1) Then
Cells(CursorRow, CommentsCol).Value = AffectedComment
End If
CursorRow = CursorRow + 1
Loop
'If Status is not "CHANGE", Go up the BOM tree and mark required parent-BOM changes
If UCase(ThisAction) <> "CHANGE" Then
AffectedComment = "Child Component Changed: " & ThisItemName
Dim TmpAffComnt As String
Dim CursorLevel As Integer
CursorLevel = ThisLevel - 1
CursorRow = ThisRow - 1
Do While (CursorLevel > 0 And CursorRow > 0)
If RowBOMLevel(CursorRow, ShowErrs) = CursorLevel Then
If UCase(Cells(CursorRow, ThisCol).Text) = "CHANGE" Then
Cells(CursorRow, ThisCol).Value = "CHANGE"
If CommentsCol <> -1 Then
Cells(CursorRow, CommentsCol).Value = AffectedComment
End If
Else
If CommentsCol <> -1 Then
TmpAffComnt = Cells(CursorRow, CommentsCol).Text & ", " & ThisItemName
Cells(CursorRow, CommentsCol).Value = TmpAffComnt
End If
End If
CursorLevel = CursorLevel - 1
End If
CursorRow = CursorRow - 1
Loop
End If
CancelledChange:
'MsgBox "Cell " & Target.Address & " has changed."
Application.EnableEvents = True
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Private Function FindColumnByName(Name As String) As Integer
'Function searches the top row of the sheet for matching column header name
Dim CurrColumnName As String
Dim CursorCol As Integer
CursorCol = 0
Do While (UCase(CurrColumnName) <> UCase(Name) And CursorCol < 100) '<100 : End at some point
CursorCol = CursorCol + 1
CurrColumnName = Cells(1, CursorCol).Text
Loop
If UCase(CurrColumnName) <> UCase(Name) Then
FindColumnByName = -1
Else
FindColumnByName = CursorCol
End If
End Function
Private Function RowBOMLevel(R As Integer, ShowErrMsgs As Boolean) As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ErrMsgStr As String
Dim LevelVal As String
LevelVal = ""
Dim Level As Integer
For c = 3 To 13 'Plan for 10 Levels Maximum
'If Not (IsEmpty(Cells(R, C))) Then
If (Cells(R, c).Text <> "" And LevelVal = "") Then
LevelVal = Cells(R, c).Text
End If
Next c
If LevelVal = "" Then GoTo NoLevel
On Error GoTo CannotConvert
Level = CInt(LevelVal)
RowBOMLevel = Level
GoTo Complete
CannotConvert:
If ShowErrMsgs Then
ErrMsgStr = "Cannot convert level " & LevelVal & " to numeric BOM Level."
MsgBox ErrMsgStr, vbOKOnly
End If
RowBOMLevel = -1
GoTo Complete
NoLevel:
If ShowErrMsgs Then
ErrMsgStr = "No Level Data Found."
MsgBox ErrMsgStr, vbOKOnly
End If
RowBOMLevel = -1
Complete:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function
Bookmarks