ترحيل نتيجة

[كعبلاوى]

أتمنى من أساتذتى فى المنتدى ترحيل نتيجة كل طالبة

فى الشيت الخاص بها 

نتيجة المدرسة.rar

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

جرب هذا الملف

تم اضافة صف فارغ قبل البيانات في الورقة "شيت" لتفادي مشكلة دمج الخلايا التي تعيق عمل اي كود

الكود

Option Explicit
Sub transfer_data()
Dim My_Rg As Range
Dim S_sh As Worksheet, My_Sheet As Worksheet
Dim i As Byte
Dim arr(1 To 4)
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
For i = 2 To 5
 arr(i - 1) = Sheets(i).Name
 Next
Set S_sh = Sheets("شيت")
Set My_Rg = S_sh.Range("b21").CurrentRegion
If S_sh.AutoFilterMode = False Then
My_Rg.AutoFilter
End If
 For i = 1 To 4
  Set My_Sheet = Sheets(arr(i))
  My_Sheet.Range("b4:f500").Clear
  My_Rg.AutoFilter field:=4, Criteria1:=arr(i)
My_Rg.SpecialCells(12).Copy My_Sheet.Range("b4")
My_Rg.AutoFilter
Next
  With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

الملف مرفق

 

نتيجة المدرسة Salim.rar

[ناصر سعيد]

6 ساعات مضت, سليم حاصبيا said:

تم اضافة صف فارغ قبل البيانات في الورقة "شيت" لتفادي مشكلة دمج الخلايا التي تعيق عمل اي كود

الكود

كنت اكره الفلتره لوجود خلايا مدمجه 

وفي بعض الاحيان نكون مضطرين لتجميد بعض الخلايا

ولكن هذ الفكره بالرغم من بساطتها رائعه ...

نترك صف تحت العناوين

ويمكن ان نخفيه

حفظك الله ورعاك يا استاذ سليم

 

تم تعديل ديسمبر 26, 2017 بواسطه ناصر سعيد

[ناصر سعيد]

My_Rg.SpecialCells(12).Copy My_Sheet.Range("B4")

مامعنى العدد 12 ... ولماذا ال 12

تم تنسيق الملف ووضع كود استاذ سليم

الرائع ونتعشم في شرح الكود

 

الفلتره للمحترم سليم حاصبيا.rar

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

7 ساعات مضت, ناصر سعيد said:

My_Rg.SpecialCells(12).Copy My_Sheet.Range("B4")

مامعنى العدد 12 ... ولماذا ال 12

تم تنسيق الملف ووضع كود استاذ سليم

الرائع ونتعشم في شرح الكود

 

الفلتره للمحترم سليم حاصبيا.rar

شكراً اخي  ناصر على المرور والاطراء الذي لا استحقه

الرقم 12 هو اختصار للعبارة "xlCellTypeVisible"

ما رأيك لوكان في العامود اكثر (أو أقل) من اريع متغيرات (Criteria)

(حاول ان تضع كود  لعدد متغير من Criteria) بالتالي متغير من الصفحات 

الافضل ان يختتم الكود بهذه العبارة 

 Erase arr
Set S_sh = Nothing: Set My_Sheet = Nothing: Set My_Rg = Nothing: i = 0

كي لا تبقى شيء في الذاكرة يثقلها

[ناصر سعيد]

2 ساعات مضت, سليم حاصبيا said:

شكراً اخي  ناصر على المرور والاطراء الذي لا استحقه

تستحق اكثر من ذلك من الكلمات  الطيبه .. جزاك الله كل خير وبارك فيك

وقد تمت التجربه بعده معايير للفرز ( صفحات اكثر باسماء المعايير )

تمت بنجاح ..

الخلاصه : لابد من ترك صفين تحت الرؤوس المدمجه ... الصف الاول الذي تركناه فاضي والصف اللي تحته يكون فيه اسماء العناوين بدون دمج  .... أليس كذلك ؟

=============

مامهعنى هذه الجمله ولماذا هذه الارقام ؟

For i = 2 To 5

 

ولماذا تختلف عن هذه الجمله

 For i = 1 To 4

 

[ناصر سعيد]

ولماذا تختلف عن هذه الجمله

 For i = 1 To 4

 

[ناصر سعيد]

انا كنت غيرت في اسماء الصفحات ... ولكني مستمر في اجراء التجارب وجدت عند اضافه صفحات جديده غير الموجوده لايتم الفلتره فيها ... ماهو التغيير المناسب في الكود ؟

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

استبدل الرقم 5 بعدد الصفحات والرقم 4 بعدد الصفحات  ناقص 1

[ناصر سعيد]

تم التغيير ولم تعمل معي ... ارجو تشريفنا بالرد

 

الفلتره للمحترم سليم حاصبيا1.rar

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

شخصياً لم اجد اي حطأ بالكود

 

الفلتره للمحترم سليم حاصبيا Modifier.rar

[ناصر سعيد]

الصفحه الاخيره لاباتي بها اي بيانات

[ناصر سعيد]

Dim arr(1 To 7)

For i = 2 To 7

For i = 1 To 5

هذه الجمل الثلاثه مطلوب كرما منك شرحها استاذ سليم

[احمد بدره]

أستاذي الفاضل ناصر سعيد قم باستبدال

For i = 1 To 4

بـ

For i = 1 To 5

وسيعمل ملف الأستاذ سليم وإليك الملف المرفق بعد التعديل

الفلتره للمحترم سليم حاصبيا Modifier.rar

[ناصر سعيد]

جزاك الله كل خير وبارك فيك

استاذ / ahmedkamelelsayed0

الكود في ابهى حلته

مع شرح الاسطر المطلوبه

بارك الله في كل من كانت له بصمه في هذا العمل

Option Explicit
Sub transfer_data()
'هذا الكود للمحترم سليم حاصبيا
'الهدف من الكود هو فلتره البيانات
'وترحيلها الى صفحات
'تم هذا الكود في 6/12/2007
'====================
Dim My_Rg As Range
Dim S_sh As Worksheet, My_Sheet As Worksheet
Dim i As Byte

'======
    'عدد صفحات الملف كاملا او اكثر
Dim arr(1 To 44)
'======

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
'======
    'عدد الصفحات المطلوب الترحيل اليها+ صفحة المصدر
For i = 2 To 7
'======

 arr(i - 1) = Sheets(i).Name
 Next
 
 'اسم صفحه المصدر
Set S_sh = Sheets("المصدر")

'بدايه النطاق المطلوب فلترته
Set My_Rg = S_sh.Range("A14").CurrentRegion

If S_sh.AutoFilterMode = False Then
My_Rg.AutoFilter
End If

'======
    'عدد الصفحات المطلوب الترحيل اليها
 For i = 1 To 6
'======
 
  Set My_Sheet = Sheets(arr(i))
  
  'نطاق المسح في صفحات الهدف
  My_Sheet.Range("B4:F500").Clear
  
  'رقم عمود الفلتره
  My_Rg.AutoFilter field:=4, Criteria1:=arr(i)
  
  'بدايه خليه النسخ في صفحات الهدف
My_Rg.SpecialCells(12).Copy My_Sheet.Range("B4")
My_Rg.AutoFilter
Next
  With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
     Erase arr
Set S_sh = Nothing: Set My_Sheet = Nothing: Set My_Rg = Nothing: i = 0
End Sub