تصحيح كود الترحيل إلى عدة صفحات بشرط اسم الصفحة

[حاتم عيسى]

السادة الافاضل مشرفي ورواد المنتدى المحترمين

تحية من عند الله تعالى

لدي ملف به كود ترحيل من إعداد الأستاذ الفاضل المحترم : محي الدين ابو البشر المحترم

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

وشكرا جزيلا لحضراتكم

مرفق الملف المراد التعامل معه

ملف بيانات العاملين.xlsm

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

1-في شيت تسجيل_الموظفين اترك الصف رقم 6  فارغاً تماما تم اخفاه لعدم الكتابة فيه عن طريق الخطأ
2- في باقي الشيتات  اترك الصف رقم 7 فارغاً تماما تم اخفاه لعدم الكتابة فيه عن طريق الخطأ

3- الكود المطلوب

Option Explicit

Sub My_filter()
Dim Ash, Itm
Dim Rg As Range
Dim Main As Worksheet
Dim Ro
With Application
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
End With
Ash = Array("التغذية", "تنسيق التعليم الإعدادي", _
 "مكتب المدير العام", "شئون الطلبة والامتحانات")
 Set Main = Sheets("تسجيل_الموظفين")
 Ro = Main.Cells(Rows.Count, "B").End(3).Row
 Set Rg = Main.Range("A7").CurrentRegion
 Main.AutoFilterMode = False
 For Each Itm In Ash
       Sheets(Itm).Range("A8").CurrentRegion.Clear

       Rg.AutoFilter 2, Itm
       Main.Range("A8:Ar" & Ro).SpecialCells(12).Copy
       With Sheets(Itm).Range("A8")
           .PasteSpecial (8)
           .PasteSpecial (12)
              With .CurrentRegion
                .Borders.LineStyle = 1
                .Font.Bold = True
                .Font.Size = 14
                .InsertIndent 1
              End With
       End With

 Next 
 
     With Application
     .Calculation = xlCalculationAutomatic
     .ScreenUpdating = True
    End With
  Main.Select
  Main.AutoFilterMode = False
End Sub

الملف مرفق

Hatem.xlsm

[خيماوي كووول]

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

اثراء الموضوع .. في حال اضافة شيت بسمى اخر .. من ضمن مسميات جهة العمل .. يمكن العمل به ..

ملف بيانات العاملين(1).xlsm

[حاتم عيسى]

أولا : أتقدم لقم جميعًا بخالص الشكر والتقدير لسرعة الرد والاهتمام بطلب كل أعضاء المنتدى الغالي.

ثانيًا : طلبي كان عند الترحيل إلى الشيتات المتعددة يتم نسخ تنسيق البيانات الموجودة في شيت المصدر وهو تسجيل التموظفين وكذلك عمل ملائمة لحجم البيانات الموجودة في عناوين الأعمدة للحجم المعد للعمود مسبقا .

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

ملحوظة هناك العديد من اسماء الشيتات الجديدة ستم اضافتها إىل عمود جهة العمل .

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

1- اي شيت تقوم بزيادته اضف اسمه الى الــ  Array  Ash 

2-  للحصول على نقس التنسيق    استبدل ما موجود في المربع الأحمر (بهذا السطر)

 Sheets(Itm).Range("A8").PasteSpecial (xlAll)

 

[حاتم عيسى]

الأستاذ الفاضل المحترم : سليم حاصبيا

تم تجربة ما قدمته حضرتك وبارك الله في حضرتك تم عمل المطلوب .

ولكن عند إضافة اسماء جديدة لم يتم إنشاء شيت بالاسم الجديد ولم يتم البيانات الجديدة.

 

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

1-تنسخ اولاً  اي شيت غير الاولى

2- تعطيها اسم 

2- ثم تدرج اسمها في الــ Array

[حاتم عيسى]

الأستاذ الفاضل المحترم : سليم حاصبيا

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

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

شكرا جزيلا لسعة صدر حضرتك

وأعتذر لكثرة الأسئلة والطلبات .

حيث

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

هل من الممكن أن يتم إنشاء شيتات تلقائية باسم البيانات الجديدة

ممكن هذا الشيء

Option Explicit
Dim i%, Lr%
Dim T As Worksheet
Dim Spes_sh As Worksheet
Dim Flter_rg As Range


Sub ADD_Sheets()
Set T = Sheets("تسجيل_الموظفين")

Lr = T.Cells(Rows.Count, 2).End(3).Row
If Lr < 8 Then Exit Sub
With T
    For i = 8 To Lr
        If Not Application.Evaluate("ISREF('" & _
         .Range("B" & i) & "'!A1)") Then
           Sheets.Add(, Sheets(Sheets.Count)).Name = _
         .Range("B" & i)
        End If
    Next
End With

End Sub
'+++++++++++++++++++++++++++
Sub transfer_data()
Application.ScreenUpdating = False
ADD_Sheets

T.Select
 Set Flter_rg = T.Range("A7").CurrentRegion
For Each Spes_sh In Sheets
       If Spes_sh.Name <> T.Name Then
        Flter_rg.AutoFilter 2, Spes_sh.Name
        Flter_rg.SpecialCells(12).Copy
        Spes_sh.Range("A7").PasteSpecial (8)
        Spes_sh.Range("A7").PasteSpecial xlAll
     End If
Next Spes_sh
T.AutoFilterMode = False
   T.Select
   With Application
     .ScreenUpdating = True
     .CutCopyMode = False
   End With
End Sub

 

 

Hatem_new.xlsm

[حاتم عيسى]

اتقدم بخالص الشكر والتقدير للأستاذ الفاضل المحترم : سليم حاصبيا

على سعة صدرة وتفانيه في تلبية طلبات رواد المنتدى الغالي وكذلك حل مشاكل الأعضاء وغره شكرا خزيلا لحضرتك ... ( تم تنفيذ المطلوب )

هل من الممكن لصق القيم وليس المعادلةوكيف يتم ترقيم البيانات في الشيات المرحل اليها من جديد تلقائيا وان شاء الله يكون طلبي الخير معذؤة لحضراتكم

وكلك اتقدم بالشكر والتقدير للأستاذ الفاضل : خيماوي كووول

على رد سيادته ومشاركته العظيمة النافعة .

كما اتقدم بالشكر والتقدير لكل القائمين  على المنتدى المحترمين كما احب انوه بان التاخر في الرد بعض الشيى ليس إل لظروف العمل فقط وانما نحمل كل التقدير والعرفان لكل القائمين على المنتدى وكل المشرفين والرواد .

شكرا لكم جميعا

 

تم تعديل ديسمبر 25, 2020 بواسطه حاتم عيسى

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

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

Option Explicit
Dim i%, Lr%
Dim T As Worksheet
Dim Spes_sh As Worksheet
Dim Flter_rg As Range
Dim RO%


Sub ADD_Sheets()
Set T = Sheets("تسجيل_الموظفين")

Lr = T.Cells(Rows.Count, 2).End(3).Row
If Lr < 8 Then Exit Sub
With T
    For i = 8 To Lr
        If Not Application.Evaluate("ISREF('" & _
         .Range("B" & i) & "'!A1)") Then
           Sheets.Add(, Sheets(Sheets.Count)).Name = _
         .Range("B" & i)
        End If
    Next
End With

End Sub
'+++++++++++++++++++++++++++
Sub transfer_data()
Application.ScreenUpdating = False
ADD_Sheets

T.Select
 Set Flter_rg = T.Range("A7").CurrentRegion
For Each Spes_sh In Sheets
       If Spes_sh.Name <> T.Name Then
       Spes_sh.Range("A7").CurrentRegion.Clear
        Flter_rg.AutoFilter 2, Spes_sh.Name
        Flter_rg.SpecialCells(12).Copy
        
            With Spes_sh.Range("A7")
              .PasteSpecial (8)
              .PasteSpecial (12)
              .PasteSpecial (4)
            End With
        
        RO = Spes_sh.Cells(Rows.Count, 1).End(3).Row
         If RO > 7 Then
          Spes_sh.Range("A8").Resize(RO - 7).Value = _
          Evaluate("Row(1:" & RO - 7 & ")")
         End If
     End If
Next Spes_sh
T.AutoFilterMode = False
   T.Select
   With Application
     .ScreenUpdating = True
     .CutCopyMode = False
   End With
End Sub

الملف لآحر مرة
و سوف يغلق الموضوع بعد الرد مباشرة لأنه  أخذ ما يزيد من الوقت

 

Hatem_Last.xlsm

[حاتم عيسى]

اتقدم بخالص الشكر والتقدير للأستاذ الفاضل المحترم : سليم حاصبيا

على سعة صدرة وتفانيه في تلبية طلبات رواد المنتدى الغالي وكذلك حل مشاكل الأعضاء شكرا جزيلا لحضرتك ... ( تم تنفيذ المطلوب بالكامل )