اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

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

 

السلام عليكم

 

 

المطلوب :

 

 

أولاً :

 

 

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

)

 

 

 

 

 

ثانياً:

 

 

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

 

 

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

FBB.zip

قام بنشر

السلام عليكم 

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

===

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

شاهد المرفق

FBB.zip

قام بنشر (معدل)

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

 

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

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

 

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

 

المدى من 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

تم تعديل بواسطه 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
  • Like 1
قام بنشر (معدل)

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

 

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

 

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

تم تعديل بواسطه DR.ZUHAIR
قام بنشر (معدل)

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

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

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

 

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

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

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

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

 

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

 

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

FBB3.zip

تم تعديل بواسطه 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
  • Like 1
قام بنشر

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

 

السلام عليكم 

 

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

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

 

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

 

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

 

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information