I have two issues with change event procedure in the MasterList.
1. When I copy a row to a new blank row, sometimes cell D senses a change and copies data into the destination. If this can happen by purpose, I would prefer it, but not with spurious sensing of change event. If this cannot happen by purpose, then I would like the macro not accept copy as a change (second choice)or I would like to avoid a row being copied in the first place.(third choice)
2. Like other rows, Row 5 can also be deleted completely after deleting cell D using hard key on keyboard. If Row 5 is deleted I would lose my formulas too.
Choice 1: I would like the formulas to Macros
Choice 2: How can I prevent the formulas being deleted
Choice 3: how can i prevent row 5 from being deleted.
The file is too large to be sent in this forum, so I am copying the code.
Code: Select all
Option Explicit
Dim mbNoEvent As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vPrevValue As Variant
Dim vCurValue As Variant
Dim lngIndex As Long
Dim strSource As String
Dim strDestination As String
Dim strList As String
Dim wshSource As Worksheet
Dim wshDestination As Worksheet
Dim wshList As Worksheet
Dim rngSource As Range
Dim rngDestination As Range
Dim lngRowCount As Long
Dim lngCount As Long
Dim wshDV As Worksheet
Dim strPW As String
Dim varUser As Variant
Dim current_row As Long
Dim column_numbers As Variant
Dim col_counter As Long
Static Exempt_Range As Range
If mbNoEvent Then Exit Sub
If Target.Row < 5 Or Target.Column > 27 Then Exit Sub
If Target.Address = ActiveSheet.ListObjects(1).HeaderRowRange.Offset(ActiveSheet.ListObjects(1).ListRows.Count).Address _
And Target.Rows.Count = 1 Then
current_row = Target.Row
column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
Set Exempt_Range = Nothing
For col_counter = LBound(column_numbers) To UBound(column_numbers)
If Exempt_Range Is Nothing Then
Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
Else
Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
End If
Next
Exit Sub
End If
If Target.Address = Target.EntireRow.Address Then Exit Sub
If Exempt_Range Is Nothing Then
current_row = Target.Row
column_numbers = Split("G,I,J,L,M,X,Y,Z", ",")
Set Exempt_Range = Nothing
For col_counter = LBound(column_numbers) To UBound(column_numbers)
If Exempt_Range Is Nothing Then
Set Exempt_Range = Range(column_numbers(col_counter) & current_row)
Else
Set Exempt_Range = Union(Exempt_Range, Range(column_numbers(col_counter) & current_row))
End If
Next
End If
If Not (Application.Intersect(Target, Exempt_Range) Is Nothing) Then Exit Sub
If Target.Count > 1 Then
Application.EnableEvents = False
Application.Undo
MsgBox "Multiple cell changes are Not allowed.", vbExclamation
Application.EnableEvents = True
Exit Sub
End If
On Error GoTo ErrHandler
mbNoEvent = True
' Get previous and current value
vCurValue = Target.Value
Application.EnableEvents = False
Application.Undo
vPrevValue = Target.Value
If vPrevValue = "" Then
Target.Value = vCurValue
ElseIf vPrevValue = vCurValue Then
' Ignore
Else
strPW = InputBox("Enter your password")
Set wshDV = Worksheets("DV")
varUser = Application.VLookup(strPW, wshDV.Range("PasswordList"), 2, False)
If IsError(varUser) Then
MsgBox "Password invalid. Change not allowed!", vbCritical
GoTo ExitHandler
End If
Target.Value = vCurValue
Call SetHistory(varUser, vPrevValue, vCurValue, Target.Address)
End If
Application.EnableEvents = True
If Intersect(Target, Me.Range("D:D")) Is Nothing Then
If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
Call CheckCol_E(Intersect(Target, Me.Range("E:E")).Offset(0, -1))
End If
GoTo ExitHandler
End If
Set wshList = Worksheets("List")
If vCurValue = vPrevValue Then
GoTo ExitHandler
End If
If vPrevValue <> "" Then
lngCount = Application.WorksheetFunction.CountIf(Me.Range("D5:" & Target.Address), vPrevValue)
' Get info about previous source range
lngIndex = Application.WorksheetFunction.Match(vPrevValue, wshList.Range("A:A"), 0)
strSource = wshList.Range("B" & lngIndex)
Set wshSource = Worksheets(strSource)
strSource = wshList.Range("C" & lngIndex)
Set rngSource = wshSource.Range(strSource)
lngRowCount = rngSource.Rows.Count
' Get info about previous destination
strDestination = wshList.Range("D" & lngIndex)
Set wshDestination = Worksheets(strDestination)
strDestination = wshList.Range("E" & lngIndex)
Set rngDestination = wshDestination.Range(strDestination).Offset(lngCount * lngRowCount, 0)
Set rngDestination = rngDestination.Resize(rngSource.Rows.Count, rngSource.Columns.Count)
' Delete
rngDestination.Delete Shift:=xlShiftUp
End If
If vCurValue <> "" Then
lngCount = Application.WorksheetFunction.CountIf(Me.Range("D5:" & Target.Address), vCurValue) - 1
' Get info about current source range
lngIndex = Application.WorksheetFunction.Match(vCurValue, wshList.Range("A:A"), 0)
strSource = wshList.Range("B" & lngIndex)
Set wshSource = Worksheets(strSource)
strSource = wshList.Range("C" & lngIndex)
Set rngSource = wshSource.Range(strSource)
lngRowCount = rngSource.Rows.Count
' Get info about current destination
strDestination = wshList.Range("D" & lngIndex)
Set wshDestination = Worksheets(strDestination)
strDestination = wshList.Range("E" & lngIndex)
Set rngDestination = wshDestination.Range(strDestination).Offset(lngCount * lngRowCount, 0)
Set rngDestination = rngDestination.Resize(rngSource.Rows.Count, rngSource.Columns.Count)
strDestination = rngDestination.Address
rngDestination.Insert Shift:=xlDown
Set rngDestination = rngDestination.Worksheet.Range(strDestination)
' Copy
rngSource.Copy Destination:=rngDestination
rngSource.Copy
rngDestination.PasteSpecial Paste:=xlPasteColumnWidths
Call UpdateValues(Target, rngDestination, wshList.Range("F" & lngIndex))
Call CheckCol_E(Target)
Else
Target.Offset(0, 1) = ""
End If
ExitHandler:
mbNoEvent = False
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Private Sub UpdateValues(ByVal MasterListColD As Range, ByVal rngDestination As Range, ByVal CpyRowOffsetadd As Long)
' rngDestination(CpyRowOffsetadd, 1) = "=if(" & _
MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 3).Address & "=""""," _
& MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 2).Address & "," & _
MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 2).Address & "&""-""&" & _
MasterListColD.Worksheet.Name & "!" & MasterListColD.Offset(0, 3).Address & ")"
'P&ID Ref
rngDestination(CpyRowOffsetadd + 1, 6) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, -3).Address
'Service Area
rngDestination(CpyRowOffsetadd + 2, 6) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, -2).Address
'Service Equipment
rngDestination(CpyRowOffsetadd + 3, 6) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, -1).Address
'Device
rngDestination(CpyRowOffsetadd + 4, 6) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 0).Address
'Device Function
rngDestination(CpyRowOffsetadd + 5, 6) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 1).Address
'Measurement
rngDestination(CpyRowOffsetadd + 6, 6) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 2).Address
'Loop Number
rngDestination(CpyRowOffsetadd + 1, 20) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 4).Address
'Jn Box ID
rngDestination(CpyRowOffsetadd + 2, 20) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 7).Address
'Device tag
rngDestination(CpyRowOffsetadd + 4, 20) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 6).Address
'Cable tag
rngDestination(CpyRowOffsetadd + 5, 20) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 8).Address
'IO tag
rngDestination(CpyRowOffsetadd + 6, 20) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 20).Address
'M.R ID
rngDestination(CpyRowOffsetadd + 3, 20) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 9).Address
'------------------------------------------------------------------------------------
'PLC Panel ID
rngDestination(CpyRowOffsetadd + 1, 30) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 12).Address
'PLC / DCS ID
rngDestination(CpyRowOffsetadd + 2, 28) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 13).Address
'PLC RAck Number
rngDestination(CpyRowOffsetadd + 3, 28) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 16).Address
'Slot Number
rngDestination(CpyRowOffsetadd + 3, 32) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 17).Address
'Channel Number
rngDestination(CpyRowOffsetadd + 4, 28) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 18).Address
'IO Type
rngDestination(CpyRowOffsetadd + 5, 28) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 19).Address
'No. of Wires
rngDestination(CpyRowOffsetadd + 6, 29) = "=" & MasterListColD.Worksheet.Name _
& "!" & MasterListColD.Offset(0, 5).Address
Application.CutCopyMode = False
End Sub
Private Sub CheckCol_E(ByVal MasterListColD As Range)
Dim ColorMark As Boolean
Dim MasterListColE As Range
Dim cel As Range
Set MasterListColE = MasterListColD.Offset(0, 1)
ColorMark = True
If MasterListColD.Value = "" Or MasterListColE.Value = "" Then
With MasterListColE.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
Exit Sub
End If
For Each cel In Application.Range(MasterListColD.Value)
If cel.Value = MasterListColE.Value Then
ColorMark = False
Exit For
End If
Next
If ColorMark Then
With MasterListColE.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
Else
MasterListColE.Borders.LineStyle = xlNone
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Range("K5:K" & Rows.Count & ",N5:N" & Rows.Count & _
",P5:P" & Rows.Count), Target) Is Nothing Then
frmSelect.Show
End If
End Sub
Best regards
Vilas Desai