اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

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

أرجوا المساعدة في ماكرو ترحيل كل مجموعة من البيانات من الصفحة الرئيسية الى رقم الشيت التابعه له مثل أسماء المجموعة 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

  • Like 3
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

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

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

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

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

تم تعديل بواسطه سيف النصر
رابط هذا التعليق
شارك

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