إنشاء أوراق عمل طبقاً للقيم داخل نطاق ونسخ البيانات المرتبطة بهذه القيمة

[المتأمل الحسني]

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

 

أرجو من الإخوة مساعدتي في عمل كود ينسخ بيانات نطاق معين بناء على إسم في هذا النطاق ثم يلصقه في ورقة جديدة و يسميها بنفس الإسم الذي في النطاق .... كما في المرفق .

 

و لكم جزيل الشكر

probl.rar

[سليم حاصبيا]

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

فقط بواسطة المعادلات وهي (مطاطة  يمكنك اضافة او تغيير البيانات)

probl salim.rar

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

الأخ الفاضل يرجى تغيير اسم الظهور للغة العربية

بارك الله فيك أخي الحبيب الغالي سليم حاصبيا

 

إثراءاً للموضوع هذا حل آخر بالأكواد ..

Sub AddDataToSheets()
    Dim Cell As Range, Header As Range, Rng As Range, EndRng As Range
    Dim row  As Long, NextRow As Long
    Dim Wks As Worksheet, SH As Worksheet
    
    Set Wks = Worksheets("ورقة1")
    Set Header = Wks.Range("A10:P12")
    Set Rng = Wks.Range("A13:M13")
    Set EndRng = Wks.Cells(Rows.Count, "M").End(xlUp)
        
    If EndRng.row > Rng.row Then Set Rng = Rng.Resize(EndRng.row - Rng.row + 1)

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
        For Each SH In Worksheets
            If SH.Name <> Wks.Name Then SH.Delete
        Next SH
        
        For row = 1 To Rng.Rows.Count
            Set Cell = Rng.Cells(row, "M")
            
            If Not IsEmpty(Cell) Then
                On Error Resume Next
                    Set Wks = ThisWorkbook.Worksheets(Cell.Text)
                
                    If Err = 9 Then
                        Worksheets.Add After:=Worksheets(Worksheets.Count)
                        Set Wks = ActiveSheet
                        Wks.Name = Cell.Text
                        Header.Copy
                        Wks.Paste Wks.Cells(1, 1)
                    End If
                
                    NextRow = Wks.Cells(Rows.Count, "M").End(xlUp).row + 1
                    Rng.Rows(row).Copy Wks.Rows(NextRow)
                On Error GoTo 0
            End If
        Next row
        
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

تقبل تحياتي

Create Sheets Based On Values In Range YasserKhalil.rar

[أسامة البراوى]

السلام عليكم
ارى ان هذا حل جميل ويفى بالغرض
وممكن ان نضيف الاسطر التالية فى نهاية الكود لكى نحافظ على الشكل العام للشيتات الجديدة
 
 

Dim I As Intger  
 For Each SH In Worksheets
           If SH.Name <> "ورقة1" Then
                For I = 1 To 6
                    SH.Columns(I).ColumnWidth = Sheets("ورقة1").Columns(I).ColumnWidth
                Next
            End If
    Next SH

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

إضافة في منتهى الجمال والروعة

تسلم يا مستر أسامة ..

شكلك هتبدع في المنتدى

في انتظار المزيد من إبداعاتك

[أسامة البراوى]

ربنا يكرمك يا استاذ ياسر

 

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

 

وبصراحة بيضيف كتير لمعلومات الواحد، فاتمنى تكون مشاركاتى مفيدة للجميع

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

ربنا يكرمك يا استاذ ياسر

 

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

 

وبصراحة بيضيف كتير لمعلومات الواحد، فاتمنى تكون مشاركاتى مفيدة للجميع

أنا لي وجهة نظر وعمرها إن شاء الله ما بتخيب ...

الأخوة في المنتدى سيستفيدون منك بشكل كبير جداً وأنا أولهم

بس يا ريت متنسناش يا كبير ..

تقبل ودي وحبي وتحياتي :fff:

[المتأمل الحسني]

ما شاء الله على الجميع .. لساني عاجز عن شكر الجميع .. فقد أثريتم الموضوع كل بجمال قدراته و ذكائه .. لا حرمني الله منكم جميعا ... و يعلم الله انني ادعو لكم دائما بالتوفيق و أن يجزيكم الله خيرا...

 

 

 

اشكركم جدا ....

[المتأمل الحسني]

الإخوة الفضلاء : أتسائل هل بالإمكان نسخ البيانات ك " قيم" من غير الدوال ؟

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

الأخ الكريم

يرجى تغيير اسم الظهور للغة العربية

 

استبدل السطر التالي

Rng.Rows(row).Copy Wks.Rows(NextRow)

وضع مكانه هذين السطرين

Rng.Rows(row).Copy
                    Wks.Rows(NextRow).PasteSpecial xlPasteValues

لتحصل على القيم فقط

 

لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

[المتأمل الحسني]

الله يرحم والديك ..

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

الله يرحم والديك ..

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

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

 

دعوة مرة أخرى أخي الكريم لتغيير اسم الظهور للغة العربية

راجع الرابط التالي

 

رابط التوجيهات

[المتأمل الحسني]

حاضر.. أبشر ... و قد غيرت الإسم إلى العربي... و العفو .

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

بارك الله فيك أخي المتأمل ..

وجزيت خيراً على تلبية طلبي

تقبل تحياتي