إضافة على كود لحذف سجل

[أبو وليد]

السلام عليكم مساء الخير

لدي كود يقوم بترحيل البيانات حسب اسم الشيت

اريد ان اضيف على الكود

قبل الترحيل يعد السجلات اذا كان 10 سجلات يحذف الأول ويضيف

واذا اقل يضيف مباشرة

 

شاكر لكم

Transfer Data To Proper Sheet Without Duplicates YasserKhalil V2.rar

[أبو وليد]

الله يستر عليك يا أستاذ ياسر خليل

غبت وغاب المنتدى

[Yasser Fathi Albanna]

إطمن أخى الحبيب / أبو وليد

أستاذنا ومعلمنا الحبيب الغالى ياسر خليل بخير والحمد لله وبصحة جيدة

بس فى المنطقة عنده كابل النت مقطوع وحتى الأن لم يتم إصلاحة

 

[أبو وليد]

الحمد لله

الله يرجعه سالما غانم

والجميع أن شاء الله

[ياسر خليل أبو البراء]

أخي الكريم أبو وليد

رغم أن الطلب غريب بعض الشيء .. ولكن جرب التعديل التالي عله يفي بالغرض

Sub TransferToAllSheets()
'Author     : YasserKhalil
'Released   : 02 - Dec. - 2015
'Use        : The Code Transfers Data In Column B To Its Proper Sheet In A
'             If Value Found In The Target Sheet, It Won't Be Transferred.
'-------------------------------------------------------------------------
    Dim Cel     As Range
    Dim LR      As Long
    
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
    End With
    
    For Each Cel In Sheets("Main").Range("A2:A" & Sheets("Main").Cells(Rows.Count, 1).End(xlUp).Row)
        If Evaluate("=ISREF('" & Cel.Value & "'!A1)") Then
        
            With Sheets("" & Cel.Value & "")
                LR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                If Application.WorksheetFunction.CountIfs(.Range("A2:A" & LR), Cel.Offset(0, 1), .Range("C2:C" & LR), Cel.Offset(0, 3)) Then GoTo Skipper
                If LR >= 12 Then LR = 2
                
                .Range("A" & LR).Resize(, 4).Value = Cel.Offset(0, 1).Resize(, 4).Value
                Cel.Offset(0, 10) = .Range("A" & LR)
            End With
            
        End If
Skipper:
    Next Cel
    
    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub ClearAllSheets()
    Dim WS      As Worksheet
    
    For Each WS In ThisWorkbook.Sheets
        If WS.Name <> "Main" Then WS.Range("A2:D1000").ClearContents
    Next WS
    
    Sheets("Main").Range("K2:K1000").ClearContents
End Sub

تقبل تحياتي