مساعدة ماكرو ترحيل مجالات معينة من عدة صفحات إلى صفحة واحدة

[عزيز عرابي]

السادة الخبراء في منتدانا الرائع

لدينا صفحة اسمها Records يتم تعبئة A1 برقم السطر الموجود في العمود C و يتم في A2 وضع المرجع المقابل لرقم السطر الموجود في العمود H آلياً بموجب الدالة Vlookup و بعدئذ يتم تفعيل الماكرو "KH2" لانشاء صفحة جديدة باسم يعتمد على قيمة الخلية A2 اعتماداً على نموذج الصفحة المسماة Temp.IBC التي يوجد فيها جدول من 4 أعمدة

نمط الملف أن يتم انشاء الكثير من الصفحات التي يبدأ اسمها بــ IBC متبوعة برقم معين مثل IBC 0999 ,,,,

المطلوب ايجاد آلية أو كود ليقوم بترحيل جدول كل صفحة من صفحات التي يبدأ اسمها بــ IBC ( مثل IBC 0999  و IBC0333 ,,,, ) إلى صفحة جديدة يوجد فيها جميع جداول الصفحات الغير محدد عددها التي تشترك بأن اسمها يبدأ بــ IBC 

اتمنى مساعدتك فالموضوع هام للغاية

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

18.rar

[عزيز عرابي]

للرفع ,,, رجاء المساعدة العاجلة و شكراً

[عزيز عرابي]

للرفع ,,, رجاء المساعدة العاجلة و شكراً

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

أخي الكريم اطلعت على الملف ولم أفهم المطلوب بشكل واضح

ما شرحته يقوم به الكود المسمى KH2 حيث يتم نسخ الورقة المسماة Temp.IBC ثم تسمى الورقة الجديدة باسم القيمة في الخلية A2 ..

الترحيل من أي الأوراق ؟ الإجابة : الأوراق التي تبدأ بالحروف IBC 

إلى أين سترحل البيانات ؟ إلى أي ورقة عمل؟ وما هي كيفية الشكل النهائي بعد الترحيل ...

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

[عزيز عرابي]

سيدي الكريم ياسر خليل أبو البراء أشكرك جداً على ردكم و آسف لعدم توضيح المطلوب بالشكل الكافي

تم رفع الملف مرة أخرى و فيه صفحة النتائج المطلوبة و تم شرح فيه كل المطلوب ان شاء الله

أتمنى مساعدتكم

18.rar

[عزيز عرابي]

للرفع ,,, رجاء المساعدة العاجلة و شكراً

[عزيز عرابي]

للرفع ,,, رجاء المساعدة العاجلة و شكراً

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

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

Sub Test()
    Dim sh          As Worksheet
    Dim shResult    As Worksheet
    Dim lr          As Long
    Dim last        As Long
    
    Application.ScreenUpdating = 0
        Set shResult = Sheets("ورقة النتائج")
        For Each sh In ThisWorkbook.Worksheets
            If Left(sh.Name, 3) = "IBC" Then
                lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
                last = shResult.Cells(Rows.Count, 3).End(xlUp).Row + 1
                If sh.Range("C4").Value <> "" Then
                    sh.Range("C4:E" & lr).Copy
                    shResult.Range("C" & last).PasteSpecial xlPasteValues
                End If
            End If
        Next sh
    Application.CutCopyMode = 0
    Application.ScreenUpdating = 1
End Sub

 

[عزيز عرابي]

شكراً جزيلاً أخي ياسر خليل أبو البراء

توجد مشكلة في الكود و هي أنه يمكن تكرار نفس النتائج في صفحة "ورقة النتائج" إذا تم تنفيذ الكود أكثر من مرة

سأحاول حل هذه المشكلة إن استطعت إن شاء الله

و بارك الله فيكم و نفع بكم

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

يمكن إضافة سطر في بداية الكود لمسح النطاق الذي سيحتوي على النتائج ..بسيطة ويمكن تسجيل ماكرو يقوم بالغرض