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

[أبو وليد]

السلام عليكم

مساء الخير

لدي ملف في مجموعة أوراق

الأولى الرئيسية

اريد ان تنسخ السجل الذي يوازي خليه الورقة نفس اسم الورقة الأخرى

 

لعل المرفق يوضح ذلك

 

Book1.rar

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

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

السلام عليكم

جرب الكود التالي ..

يضع السجل (الخلية التي توازي خلية الورقة) في الخلية A1 في الورقة المطابقة لاسم ورقة العمل

أرجو أن يكون المطلوب ..

Sub Transfer()
    Dim Cel As Range
    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
            Sheets("" & Cel.Value & "").Range("A1") = Cel.Offset(0, 1).Value
        End If
    Next Cel
End Sub

 

 

[أبو وليد]

بارك الله فيك

وضعته في الصفحه الرئيسيه ولم يحدث شيء

ممتاز

وجدته ماكرو

جميل جدا عزيزي

 

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

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

أخي الكريم

لا أستطيع فهم المطلوب بشكل كافي

يرجى التوضيح مع ذكر مثال بما تطلب ..أو ارفق بعض النتائج المتوقعة لتتضح الصورة

[أبو وليد]

اقصد في المرة الأولى توضع في الخلية الأولى

عند التنفيذ مره أخرى تنقل للخلية التي تليها مع ملاحظة أن لا تتكرر القيم يعني لو تمت الإضافة اذا كانت القيمة موجودة لا تضاف

 

تقبل شكري وتقديري

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

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

Sub Transfer()
    Dim Cel As Range, LR As Long
    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 = IIf(IsEmpty(.Range("A1")), 1, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                If Application.WorksheetFunction.CountIf(.Range("A1:A" & LR), Cel.Offset(0, 1).Value) >= 1 Then GoTo Skipper
                Sheets("" & Cel.Value & "").Range("A" & LR) = Cel.Offset(0, 1).Value
            End With
        End If
Skipper:
    Next Cel
End Sub

 

 

Transfer Data To Proper Sheet Without Duplicates YasserKhalil.rar

[أبو وليد]

اسأل الله سبحانه وتعالى أن يرزقك في الدنيا والآخرة

سؤال أخير

 

هذا الكود ينفع لأكثر من خليه بس أضيف أسماء الخلايا صحيح

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

أخي الكريم

يمكنك إضافة ما تشاء من خلايا ...على حسب ما فهمت من سؤالك

حاول توضح أكتر المطلوب ..ودائماً ارفق شكل النتائج المتوقعة لتجد المساعدة من إخوانك بالمنتدى

[أبو وليد]

بارك الله فيك

 

المرفق يوضح مااقصده

Transfer Data To Proper Sheet Without Duplicates YasserKhalil.rar

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

يرجى توضيح النقطة الثانية في المرفق

ويرجى التوضيح بشكل عام في المشاركة أولاً ..

بالنسبة لنقل السجل بالكامل أمره بسيط .. ماذا بالنسبة للتكرار (عدم نقل القيمة في حالة تكرار أي عمود : القيمة أم الاسم أم التاريخ أم العمر؟؟)

 

[أبو وليد]

صباح الخير استاذي الفاضل

عدم نقل القيمة في حال تكرار القيمة والتاريخ

 

النقطة الثانية

مطلوب أن تكون قيمة الخلية أخر قيمة في العمود

 

واسعد الله ايامك بكل خير

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

هل تقصد أن يكون عمود القيمة في بقية الأوراق في آخر الأعمدة وليس كما في المرفق في أول عمود

وضح بمرفق فيه شكل النتائج المتوقعة بارك الله فيك

 

 

[أبو وليد]

تم التوضيح في المرفق

 

وفقك الله

Transfer Data To Proper Sheet Without Duplicates YasserKhalil.rar

[أبو وليد]

لا أدري استاذي

هل وصلت المعلومة

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

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

[أبو وليد]

رائع بارك الله فيك

 

ووفقك في الدنيا والآخرة

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

الحمد لله أن تم المطلوب على خير

الحمد لله الذي بنعمته تتم الصالحات

ومشكور على دعائك الطيب

[أبو وليد]

صباح الخير استاذي الفاضل

 

بعد أن طبقت الكود على ملفي الرئيسي

يعمل الكود بصورة رائعة جدا وحسب المطلوب

الا انه عند الانتهاء يعطيني رساله مفاده

run time error 13

type mismatch

ويحولني على صفحة الكود

ويعلم على السطر التالي باللون الأصفر

If Evaluate("=ISREF('" & Cel.Value & "'!A1)") Then

 

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

ضع قبل هذا السطر سطر لتخطي الخطأ

On Error Resume Next

[أبو وليد]

تسلم وتدوم

الف شكر لك وسرعة تجاوبك ومساعدتنا

 

كتب الله لك الأجر والعافية

[أبو وليد]

السلام عليكم

صباح الخير استاذي الفاضل

 

ادري اني زودتها ولكن كرمكم يجعلني اتسأل باستمرار

في كودك السابق

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

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

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

 

يعلم الله حاولت دون فائدة

بارك الله فيك

[أبو وليد]

للتذكير

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

[أبو وليد]

السلام عليكم

صباح الخير استاذي الفاضل

 

ادري اني زودتها ولكن كرمكم يجعلني اتسأل باستمرار

في كودك السابق

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

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

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

 

يعلم الله حاولت دون فائدة

بارك الله فيك

[أبو وليد]

الأستاذ / ياسر خليل

 

مختفي

أن شاء الله يكون المانع خير

[أبو وليد]

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