ترحيل البيانات الى أكثر من شيت وفقا لشرط

[سيف النصر]

الاخوة الفضلاء

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

أرجوا المساعدة في ماكرو ترحيل كل مجموعة من البيانات من الصفحة الرئيسية الى رقم الشيت التابعه له مثل أسماء المجموعة 1 يتم ترحيلها إلى شيت 1 وأسماء المجموعة 2 يتم ترحيلها إلى شيت 2 مع إمكانية ترحيل جميع المجموعات دفعة واحدة أو ترحيل المجموعة المختارة فقط ، مع العلم أنه يتم مسح البيانات من جميع الشيتات وإضافة بيانات جديدة يومياً لذا أرجوا ان يكون هناك امكانية مسح البيانات من جميع الشيتات أو المجموعة المختارة فقط  وامكانية نقل البيانات من الشيتات الى شيت الأرشيف بعد الضغط على أيكون ابداء .
بإختصار 
 

- إمكانية ترحيل جميع المجموعات دفعة واحدة كل مجموعة الى الشيت المخصص لها بمجرد الضغط على أيكونة ابدا أو ترحيل المجموعة المختارة فقط مثل المجموعة رقم 5 إلى الشيت رقم 5 مع العلم أن عدد الأصناف ليس ثابت قد يكون المجموعة تحتوي على عدد أصناف 10 اليوم وغدا قد تكون 20 أو أكثر أو أقل .   - إمكانية مسح البيانات من جميع الشيتات دفعة واحدة بمجرد الضغط على أيكونة ابدا أو  مسح البيانات من المجموعة المختارة فقط مثل المجموعة رقم 5 من الشيت رقم 5 . - إمكانية نقل البيانات من الشيتات الى شيت الأرشيف بعد الضغط على أيكونة ابداء حيث أنه يتم التعديل على الأصناف ولكن في الشيت الخاص بالمجموعة التابعة لها لذلك لابد من نقل البيانات بعد التعديل عليها من الشيتات الى شيت الأرشيف . مرفق ملف كمثال وجزاكم الله كل خير ،،،

تعديل - مجموعات الأصناف.xlsx

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

1-تغيير اسم الصفحة الأولى الى Main من اجل نسح الكود بطريقة صحيحة دون مشاكل اللغة العربية

2- الماكرو اللازم  عدد (2)

Option Explicit

Sub From_One_to_ALL()
    Dim sh As Worksheet
    Dim Itm, m%
    Dim Filter_Range As Range
    Dim AR()
Application.ScreenUpdating = False
  Set Filter_Range = _
  Sheets("Main").Range("A1").CurrentRegion
m = 1

For Each sh In Sheets
  If sh.Name <> "Main" Then
    ReDim Preserve AR(1 To m)
    AR(m) = sh.Name
    m = m + 1
  End If
 Next
 For Each Itm In AR
  Sheets(Itm).Range("A1").CurrentRegion.Clear
  Filter_Range.AutoFilter 1, Sheets(Itm).Name
  Filter_Range.SpecialCells(12).Copy _
  Sheets(Itm).Range("A1")
 Next
 Application.CutCopyMode = False
 If Sheets("main").AutoFilterMode Then
 Sheets("Main").Range("A1").AutoFilter
 End If
 Erase AR
Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++
Sub Clear_all()
 Dim sh As Worksheet
 For Each sh In Sheets
  If sh.Name <> "Main" Then
   sh.Range("A1").CurrentRegion.Clear
  End If
 Next
End Sub

الملف مرفق

GROUPING_SHEETS.xlsm

[سيف النصر]

الملف يعمل بشكل مبهر .

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

اتمنى لو يسمح وقت حضرتك  

- ازاي احدد رنج البيانات المراد نقلها الي الشيتات صف وعمود . وتحديد الخلية التي يبدأ عندها لصق البيانات في الشيتات . والبيانات المنقولة تكون قيمة فقط بدون تنسيق زي مثلا   past spcial value

- وان يتم مسح البيانات لرنج محدد صف وعمود وذلك للحفاظ على تنسيق كل شيت .

أسف جدا للإطالة

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

تم تعديل سبتمبر 14, 2020 بواسطه سيف النصر

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

توضيح

 

 

[سيف النصر]

جزاكم الله خيرا على هذا المجهود الكبير .

زادك الله علما وفهما ويسر لك أمرك .