I’ve got macros from expert in this forum according to my request (purpose 1) which link to a sheet when I change a certain cell in column D and/or E, the related entry (check if same in column C) will auto change the value (either above or below rows).
(purpose 2) for check duplicate entry in column C by exactly the same entry in (col C, col F & col G) and highlight it.
The pros is what I want to achieve is working, however the cons is it runs really slow.
I know it will be reapplied every time the cell is changed. I m ok for the checking made after all entry I made too. Would anyone help please?
My Question: Is there any way (being able to restrict the cols I want to execute code for checking) / other method to tweak this code to make the run faster?
Here’s my code below,
Private Sub Worksheet_Change(ByVal Target As Range)
‘PURPOSE 1: Check duplicate entry in column (C, F and G)
If Target.Count = 1 And Target.Column = 7 And Len(Trim(Cells(Target.Row, 3).Value)) > 0 Then
For Each Aval In Range(“C:C”).SpecialCells(xlCellTypeConstants, 2)
If Aval.Row Target.Row Then
If UCase(Trim(Cells(Target.Row, 3).Value) & Trim(Cells(Target.Row, 6).Value) & Trim(Cells(Target.Row, 7).Value)) = UCase(Trim(Cells(Aval.Row, 3).Value) & Trim(Cells(Aval.Row, 6).Value) & Trim(Cells(Aval.Row, 7).Value)) Then
pt = MsgBox(“Duplicate record. Please update the existing record!”, vbCritical, “Duplicate entry”)
End If
End If
Next
End If
Dim rng As Range, Dn As Range, Txt As String
Set rng = Range(Range(“C5”), Range(“C” & Rows.Count).End(xlUp))
If Not Intersect(rng.Resize(, 6), Target) Is Nothing Then
rng.Resize(, 6).Font.Color = vbBlack
With CreateObject(“scripting.dictionary”)
.CompareMode = vbTextCompare
For Each Dn In rng
Txt = Dn.Value & Dn.Offset(, 3) & Dn.Offset(, 4)
If Not .exists(Txt) Then
.Add Txt, Dn
Else
.Item(Txt).Resize(, 6).Font.Color = vbRed
Dn.Resize(, 6).Font.Color = vbRed
End If
Next
End With
End If
‘PURPOSE 2: Autochange for all related data if last entry Text value changed in column D
Dim lastRow As Long
Dim myRow As Long
‘ Exit if more than one cell updated at the same time
‘If Target.Count > 1 Then Exit Sub
‘ Exit if update is not to columns D or E
If Target.Column 5 Then Exit Sub
‘ Exit if change is made to rows 1
If Target.Row < 5 Then Exit Sub
Application.ScreenUpdating = False
' Find last row in column C with data
lastRow = Cells(Rows.Count, "C").End(xlUp).Row
' Loop through all rows in column C
For myRow = 5 To lastRow
' Make sure you aren't checking the target row
If myRow Target.Row Then
‘ Check to see if column C values match
If Cells(myRow, “C”) = Cells(Target.Row, “C”) Then
‘ Update column D or E
Application.EnableEvents = False
Cells(myRow, Target.Column) = Target
Application.EnableEvents = True
End If
End If
Next myRow
Application.ScreenUpdating = True
End Sub
