نسخ بيانات من ورقه لمجموعة اوراق

[أبو وليد]

ممكن احد يساهم مشكورا في الحل

[أبو وليد]

سبحان الله وبحمده

[أبو وليد]

في ‏٢٠‏/‏٠٢‏/‏١٤٣٧ at 14:06, ياسر خليل أبو البراء said:

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
                
                .Range("A" & LR).Resize(, 4).Value = Cel.Offset(0, 1).Resize(, 4).Value
                Cel.Offset(0, 10) = .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row)
            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

أخي الكريم

جرب التعديل بالشكل التالي عله يفي بالغرض

إليك الملف المرفق فيه ما تطلب إن شاء الله

 

Transfer Data To Proper Sheet Without Duplicates YasserKhalil V2.rar

السلام عليكم

صباح الخير

هذا كود ترحيل بشروط للأستاذ / ياسر خليل

وطبت إضافة للكود ويبدو أن الأستاذ غير متواجد في المنتدى من كم يوم

أن شاء الله أن يكون بصحة وعافيه وسلامه ويكون المانع خير

 

أذا احد من الاخوة يستطيع مساعدتي في طلبي

 

نقل السجلات إلى الأوراق

حبيت أضيف له أمر عند كل نقل يتأكد أذا عدد السجلات 355 يتم مسح أول سجل في الورقة

عشان ما يكون الملف في سجلات مالها داعي

 

بارك الله فيكم

[أبو وليد]

سبحان الله وبحمده