كود رائع يا بن مصر الرائع
لكن من اجل لفت نظرك فقط الى حاجة بسيطة و سهلة حتى يجري الأمر بسرعة اكبر بكثير و لمنع ارتجاج الشاشة يجب ان تضيف سطرين الى الكود فقط
Application.screen updating = false
Application.screen updating = true
Sub copyandremoveblankorduplicate()
Dim ws, ws1, ws2 As Worksheet
Dim lr, lr1, lr2, lrc, lrcr As Long
Set ws = ThisWorkbook.Sheets(1)
Set ws1 = ThisWorkbook.Sheets(2)
Set ws2 = ThisWorkbook.Sheets(3)
lr = ws.Cells(Rows.Count, 3).End(xlUp).Row
lr1 = ws1.Cells(Rows.Count, 7).End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, 7).End(xlUp).Row
ws.Range("C4:C" & lr + 1).ClearContents
ws1.Range("G4:G" & lr1).Copy Destination:=ws.Range("C4")
lrc = ws.Cells(Rows.Count, 3).End(xlUp).Row + 1
ws2.Range("G4:G" & lr2).Copy Destination:=ws.Range("C" & lrc)
Application.CutCopyMode = False
lrcr = ws.Cells(Rows.Count, 3).End(xlUp).Row
Application.ScreenUpdating = False
For x = lrcr To 5 Step -1
If Application.WorksheetFunction.CountIf(Range("C4:C" & x), Range("C" & x).Text) > 1 Or ws.Range("C" & x).Text = "" Then
Range("C" & x).EntireRow.Delete
End If
Next x
Application.ScreenUpdating = True
End Sub
انظر الى الكود كيف يصبح و جربه بنفسك و قارن السرعة
عدم المؤاخذهة (لفت نظر مش اكثر)