ترحيل بشرط معين

[DR.ZUHAIR]

الاخوة الكرام

 

السلام عليكم

 

 

المطلوب :

 

 

أولاً :

 

 

كيف يمكن ترحيل البيانات من الصفحة 2 إلى الصفحة 1 بشرط تساوي بيانات العمود G  مع العمود G بالورقة 1 أي مثلاً عند FBB-1 في ورقة 2 يتم نقل البيانات إلى FBB-1 في ورقة 1 مع الإبقاء على البيانات الاخرى كما هي ... ( والمقصود بالتساوي هنا هو تساوي كل حالة بذاتها على حدة

)

 

 

 

 

 

ثانياً:

 

 

عمل متوالية تتزايد  برقم 1 كل 6 خطوات في الورقة رقم 1 أي FBB-3 ، FBB-2 ، FBB-1 ... وهكذا على أن تتكرر FBB- عدد 6 مرات

 

 

وجزاكم الله عنا كل خير 

FBB.zip

[DR.ZUHAIR]

عذراً للرفع 

[عبدالله المجرب]

السلام عليكم 

بخصوص المطلوب الاول ماهو معيار الترحيل (لان الموجود غير مفهوم)

===

بخصوص المطلوب الثاني تم عمل دالة لعمل المتوالية المطلوبة

شاهد المرفق

FBB.zip

[DR.ZUHAIR]

السلام عليكم ورحمة الله وبركاته

 

أستاذنا الفاضل عبدالله جزاك الله عنا كل الخير وجعله في ميزان حسناتك .... 

المطلوب الثاني قمت بإنجازه على أكمل وجه  فبارك الله لنا فيك ...

 

أما عن المطلوب الأول فأنا أعتذر إن لم يكن سؤالي واضح ... وهو ببساطة أريد كود يقوم بترحيل قيم الخلايا  على أن يكون الشرط كالتالي :

 

المدى من G2:G7 بالصفحة رقم 2 يساوي X      

حيث X  هي قيم الخلايا المساوية له في العمود G بالصفحة رقم 1 

عندها يتم ترحيل قيم الخلايا بالأعمدة 1 إلى 6 بالصفحة 2 إلى الصفحة رقم 1

(وبشرط عدم مسح البيانات المؤرشفة في صفحة رقم 1 ولكن نسخ البيانات الجزء الموجود بالمدى G2:G7 من الصفحة 2 إلى ما يقابلها بالصفحة رقم 1)

 

 

 

مثال :

 

FBB-3  في الصفحة 2  = FBB-3 في الصفحة 1

 

 

عندها يتم ترحيل البيانات إلى الصفحة رقم 1 

 

 

مرفق ملف لشرح المطلوب

FBB2.zip

تم تعديل أبريل 30, 2013 بواسطه DR.ZUHAIR

[عبدالله المجرب]

السلام عليكم 

ضع هذا الكود في زر أمر في الورقة 2

Sub Abu_Ahmed()
Dim cl As Range
Set Mysh = Sheets("1")
For Each cl In Mysh.Range("G2:G" & Mysh.[G10000].End(xlUp).Row)
If cl = [G2] Then
Mysh.Range("A" & cl.Row & ":" & "F" & cl.Row + 5).Copy
Range("A2").PasteSpecial xlPasteValues
Exit For
End If
Next
Set Mysh = Nothing
End Sub

[DR.ZUHAIR]

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

 

لكن أخي الفاضل المطلوب هو ما قمت به تماماً ولكن بالعكس نقل البيانات من ورقة 2 إلى ورقة 1.... وأنا جد متأسف لأنني أرهقتك ...

 

فجزاك الله عنا كل خير

تم تعديل أبريل 30, 2013 بواسطه DR.ZUHAIR

[عبدالله المجرب]

السلام عليكم 

 

 

(وبشرط عدم مسح البيانات المؤرشفة في صفحة رقم 1

 

 

هل ممكن توضيح لهذه الجزئية

[DR.ZUHAIR]

(وبشرط عدم مسح البيانات المؤرشفة في صفحة رقم 1

==================================

المقصود أخي الفاضل الابقاء عليها كما هي أي عدم مسحها فهي الورقة التي ستستقبل البيانات وتستحدث  البيانات التي تتساوى فيها القيم بالعمود G بالورقة 1 مع الخلية G2 بالورقة 2

 

=================================

أخي المطلوب هو ما قمت به تماماً ولكن العكس صحيح فقط 

==============================================

أي أن نقل المجال A2:F7 من الورقة 2 إلى ورقة رقم 1 بشرط تساوي قيمة الخلية G2 بالورقة 2 مع القيم بالعمود G  بورقة رقم 1

 

مرفق ملف + فيديو للتوضيح

 

ولك كل المودة والتقدير

FBB3.zip

تم تعديل أبريل 30, 2013 بواسطه DR.ZUHAIR

[عبدالله المجرب]

السلام عليكم 

اذاً استبدل الكود السابق بهذا

Sub Abu_Ahmed()
Dim cl As Range
Set Mysh = Sheets("2")
For Each cl In Range("G2:G" & [G10000].End(xlUp).Row)
If cl = Mysh.[G2] Then
Mysh.Range("A2:F7").Copy
Range("A" & cl.Row).PasteSpecial xlPasteValues
Exit For
End If
Next

Application.CutCopyMode = False
Set Mysh = Nothing
End Sub

 

 

 

ولكن ضع زر الأمر في الورقة 1

[عبدالله المجرب]

وبهذه الصسغة ممكن وضع زر الأمر في اي ورقة

Sub Abu_Ahmed()
Dim cl As Range
Set Mysh = Sheets("2")
Set Mysh1 = Sheets("1")
For Each cl In Mysh1.Range("G2:G" & Mysh1.[G10000].End(xlUp).Row)
If cl = Mysh.[G2] Then
Mysh.Range("A2:F7").Copy
Mysh1.Range("A" & cl.Row).PasteSpecial xlPasteValues
Exit For
End If
Next
Application.CutCopyMode = False
Set Mysh = Nothing
Set Mysh1 = Nothing
End Sub

[DR.ZUHAIR]

الأخ الفاضل عبدالله المجرب

 

السلام عليكم 

 

جزاك الله عنا كل الخير وفتح الله عليكم ... الكود المرفق منكم أنجز العمل بنجاح فبارك الله فيك ... وأعذرني لتأخري في الرد

وأثناء تجوالي في أرشيف المنتدى قبل أن أتحصل على الكود المرفق منكم وجدت كود مشابه لما أطلبه وهو من عمل الأخ الفاضل :

 

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

 

على هذا الرابط :

 

http://www.officena.net/ib/index.php?showtopic=15490

 

إلا أن الأمر أحتاج مني لتعديل في الكود ومعادلة التسلسل حتى يتناسب مع طلبي لذا إسمح لي بعد إذنك بنقله حتى تعم الفائدة على الجميع :

 

Sub ZUHAIR()
Dim i, ii As Integer


    For ii = 2 To 7
    
        For i = 2 To 200
            If Sheets("2").Cells(ii, 7) = Sheets("1").Cells(i, 7) Then
                Sheets("1").Cells(i, 7).Offset(0, -6) = Sheets("2").Cells(ii, 1)
                Sheets("1").Cells(i, 7).Offset(0, -5) = Sheets("2").Cells(ii, 2)
                Sheets("1").Cells(i, 7).Offset(0, -4) = Sheets("2").Cells(ii, 3)
                Sheets("1").Cells(i, 7).Offset(0, -3) = Sheets("2").Cells(ii, 4)
                Sheets("1").Cells(i, 7).Offset(0, -2) = Sheets("2").Cells(ii, 5)
                Sheets("1").Cells(i, 7).Offset(0, -1) = Sheets("2").Cells(ii, 6)
                
            End If
        Next
    Next
    MsgBox "تم الترحيل"
End Sub

أجدد لكم التحية وجزاكم الله عنا كل خير ...

NEW FBB.zip