كود واحد يرحل جميع البيانات الى جميع الادارات وفق اسم الادارة ونوع المدرسة

[عمار الدخخنى السعيد]

عند قاعدة بيانات بها صفحة البيانات الخاصة بكل مدرسة وهناك عدد من اوراق العمل مسماه باسم كل ادارة والادارة مقسمة الى عدة اوراق عمل مثال " صفحة البيانات الاساسية احتوى على كل اسماء المعلمين بالمحافظة وكذلك تخصصاتهم ومؤهلاتهم وتاريخ التعيين واسم الادارة ونوع المدرسة (رسمى عربى -رسمى لغات) ....الخ عملت كود لكل صفحة لترحيل البيانات اليها وفق الاسم الادارة ونوع المدرسة (عربى رسمى - عربى لغات) علما بان التصفية تكون وفق معيارين اسم الادارة ونوع المدرسة وموجودين فى صفحة البيانات الاساسية فى العمودين (u-v)

 المشكلة الكود بطىء جددددددا فى نقل البيانات وممكن فضلا كود واحد يرحل جميع البيانات الى جميع الادارات وفق اسم الادارة ونوع المدرسة بدل عمل كود  ترحيل لكل ادارة حسب نوع المدرسة واسم الادارة

وأسف على الاطالة,وشكررا جزيلا

مرفق الملف لابداء اراء معلمى وخبراء الاكسل

وده الكود اللى بشتغل عليها لترحيل البيانات الى كل ادارة وفق معيار اسم الادارة ونوع المدرسة

Sub filter_me11()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim My_Sh As Worksheet, Source_Sh As Worksheet
Dim last_row As Long
Dim lr As Long
Dim My_rg As Range
Dim My_First As Long, i As Long
My_First = 7
Set My_Sh = Sheets(" الغردقة رسمى لغات"): Set Source_Sh = Sheets("بيانات")
last_row = My_Sh.Cells(Rows.Count, "d").End(3).Row
If last_row < 2 Then last_row = 2
lr = Source_Sh.Cells(Rows.Count, "b").End(2).Row
If lr < 7 Then lr = 7
My_Sh.Range("d7:ab" & last_row).ClearContents
For i = 1 To lr
If Source_Sh.Range("u" & i) = "الغردقة" _
And Source_Sh.Range("v" & i) = "رسمى لغات" Then
With My_Sh
.Cells(My_First, "D") = Source_Sh.Range("b" & i)
.Cells(My_First, "E") = Source_Sh.Range("c" & i)
.Cells(My_First, "F") = Source_Sh.Range("d" & i)
.Cells(My_First, "G") = Source_Sh.Range("e" & i)
.Cells(My_First, "H") = Source_Sh.Range("f" & i)
.Cells(My_First, "I") = Source_Sh.Range("g" & i)
.Cells(My_First, "J") = Source_Sh.Range("h" & i)
.Cells(My_First, "K") = Source_Sh.Range("i" & i)
.Cells(My_First, "L") = Source_Sh.Range("j" & i)
.Cells(My_First, "M") = Source_Sh.Range("k" & i)
.Cells(My_First, "N") = Source_Sh.Range("l" & i)
.Cells(My_First, "O") = Source_Sh.Range("m" & i)
.Cells(My_First, "P") = Source_Sh.Range("n" & i)
.Cells(My_First, "q") = Source_Sh.Range("o" & i)
.Cells(My_First, "r") = Source_Sh.Range("p" & i)
.Cells(My_First, "s") = Source_Sh.Range("q" & i)
.Cells(My_First, "t") = Source_Sh.Range("r" & i)
.Cells(My_First, "u") = Source_Sh.Range("s" & i)
My_First = My_First + 1
End With
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Call MsgBox("تم تسكين معلمات الغردقة رسمى لغات", mBox, " عمار الدخخنى")
End Sub

 

بيانات المدارس.xlsx

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

 

أولا  من اول نظرة لحجم الملف  لاحظت انه كبير جدأ حوالي واحد  ميغا فمن الطيبعي ان يكون بطيئاً

      حاول التقليل من التنسيقات الملونة والتنسيقات الشرطية  لان كل هذا يؤثر على السرعة

     الخلايا المدمجة علة العلل و عدو المعادلات والأكواد الأول  حاول قدر الامكان التخفيف منها

 

ثانيا لما لا تقوم بتحيمل الكود بشكل يمكن قرائته

      استعمل اشارة الكود الموجودة في القائمة عنك

1-اضغط اولا على الايقونة  <> في الشرط العلوي للمشاركة

2- انسخ الكود الى النافذة التي تظهر

3-اضغط على اضف للمشاركة

[Ali Mohamed Ali]

بعد اذن الأستاذ سليم -تفضل

 

كود واحد يرحل جميع البيانات الى جميع الادارات وفق اسم الادارة ونوع المدرسة2.xlsm

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

يارك الله فيك اخي علي

وهذا كود اخر يعتمد على  Dictionary لتحديد المدارس المطلوبة و على Auto Filter لكل مدرسة

اظن انه أسرع  لنقل ال Data  الى الصفحة المطلوبة

Option Explicit
Sub test()
'====>>> CREATED BY SALIM ON 28/7/2019
    Application.ScreenUpdating = False
'+++++++++++++++++++++++++++++++++++++++ Start Of DIM
    Dim Fst As Worksheet: Set Fst = Sheets("Data") 'First Sheet
    Dim Sec As Worksheet ' Seconde sheet
    Dim LRU% ' LRU Num of Rows in First sheet column U
    Dim i%, ky, m%: m = 6   'm row's number when the data will start
    Dim D As Object ' D Dictionary
    Dim Fst_Rg As Range 'My range On first sheet
 '+++++++++++++++++++++++++++++++++++++++ End Of DIM
 
 Set D = CreateObject("Scripting.Dictionary")
  LRU = Fst.Cells(Rows.Count, "U").End(3).Row
  Set Fst_Rg = Fst.Range("a2").Resize(LRU, 30)
  
 
 '''''''''''''''''''''''''''Start Of For_next Loop to fill the Dictionary
  For i = 3 To Fst_Rg.Rows.Count
    If Not D.exists(Fst.Cells(i, "U").Value) And _
    Len(Fst.Cells(i, "U")) > 3 Then
     D.Add Fst.Cells(i, "U").Value, ""
    End If
  Next i
 '''''''''''''''''''''''''''End Of For_next Loop to fill the Dictionary

'+++++++++++++++++++++++++++++++++ fil All sheets with auto filter
For Each ky In D.keys

 Set Sec = Sheets(ky)
     Sec.Range("c6").CurrentRegion.ClearContents ' Clean Up the Data in Seconde sheet
     Fst_Rg.AutoFilter 21, CStr(ky) 'filter by column(21)==>> N
     Fst_Rg.Cells(1, 1).Resize(LRU - 1, 20).SpecialCells(12).Copy _
     Sec.Range("C" & m)
  
Next ky
'++++++++++++++++++++++++++++++++++++
 
 If Fst.FilterMode Then _
    Fst.ShowAllData: Fst_Rg.AutoFilter '====== Clear Autofilter from sheet Data

   '++++++++++++++++++++++++++++++++++++++ Clean Up the Memory
   D.RemoveAll: Set D = Nothing: Set Fst_Rg = Nothing
   Set Fst = Nothing: Set Sec = Nothing
   '++++++++++++++++++++++++++++++++++++++
Application.ScreenUpdating = True

End Sub

 

 

[عمار الدخخنى السعيد]

شكراا استاذ سليم

وشكرا استاذ على محمد

وجعله الله فى ميزان حسناتكم