تعديل بسيط على الكود لازالة كل المكرر دفعة واحدة
CODE
Sub My_Code()
Dim H As Worksheet, Nakl As Worksheet
Dim S As Worksheet
Dim lr_h%, lr_S, Newlr_h%, newlr_S%
Dim Cop_rg5 As Range, Cop_rg10 As Range
Set H = Sheets("الهيئة"): Set Nakl = Sheets("للنقل")
Set S = Sheets("السجل")
Set Cop_rg5 = Nakl.Range("B5").Resize(, 11)
Set Cop_rg10 = Nakl.Range("B10").Resize(, 7)
lr_S = S.Cells(Rows.Count, 2).End(3).Row + 1
If lr_S <= 4 Then lr_S = 4
lr_h = H.Cells(Rows.Count, 2).End(3).Row + 1
If lr_h <= 4 Then lr_h = 5
Cop_rg5.Copy: H.Range("b" & lr_h).PasteSpecial
Cop_rg10.Copy: S.Range("b" & lr_S).PasteSpecial
Newlr_h = H.Cells(Rows.Count, 2).End(3).Row
newlr_S = S.Cells(Rows.Count, 2).End(3).Row
H.Select
Call remove_dupliacte(H.Range("b5:L" & Newlr_h), 11)
Newlr_h = H.Cells(Rows.Count, 2).End(3).Row
If Newlr_h = 5 Then
S.Cells(5, 1) = 1
Else
H.Cells(5, 1).Resize(Newlr_h - 4).Formula = "=IF(B5="""","""",MAX($A$4:A4)+1)"
End If
H.Range("a4").CurrentRegion.Borders.LineStyle = 1
S.Select
Call remove_dupliacte(S.Range("b4:H" & newlr_S), 7)
newlr_S = S.Cells(Rows.Count, 2).End(3).Row
If newlr_S = 4 Then
S.Cells(4, 1) = 1
Else
S.Cells(4, 1).Resize(newlr_S - 2).Formula = "=IF(B4="""","""",MAX($A$3:A3)+1)"
End If
S.Range("a4").CurrentRegion.Borders.LineStyle = 1
Nakl.Select
Cop_rg5.ClearContents: Cop_rg10.ClearContents
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub remove_dupliacte(rg As Range, x)
Dim i%, lr, Answer As Byte
Dim col As New Collection
Dim arr, Rg_Del As Range
rg.Rows.Hidden = False
lr = rg.Columns(1).Rows.Count + 4
For i = 1 To lr
If rg.Cells(i, 1) = vbNullString Then GoTo next_i
arr = Application.Transpose(Application.Transpose(rg.Cells(i, 2).Resize(, x)))
arr = Join(arr, "*")
On Error Resume Next
col.Add i, arr
If Err.Number > 0 Then
If Rg_Del Is Nothing Then
Set Rg_Del = rg.Cells(i, 1)
Else
Set Rg_Del = Union(Rg_Del, rg.Cells(i, 1))
End If
End If
next_i:
Next
If Rg_Del Is Nothing Then Exit Sub
Rg_Del.Interior.ColorIndex = 6
Answer = MsgBox("You have Dulicates in :" & Rg_Del.Address & Chr(10) & _
"Do you want to delete them", 4)
If Answer = 6 Then
Rg_Del.EntireRow.Delete
End If
End Sub
تعديل واضافة كود
