سليم حاصبيا

هل يمكن لبرنامج اكسل ان يقوم بتقسيم الصورة علي مجموعة خلايا بنسبة مئوية معينة انظر لهذا الملف لتفهم ما أقصده Complete_picture.xlsx

في الخليه ِAD6 ( يوجد للموظف اكثر من طلب المطلوب إيجاد اخر تاريخ لطلب الموظف من الشيت - Data ) هذا ما تفعله النعادلة الموضوعة في AD6 )جرب ان تغير التاريخ في الشيت data وترى النتيجة)

تم معالجة الامر وتعديل المعادلات للحصول على سرعة أفضل اذ ليس من المعقول ان تأخذ جدولا من b4 الى xfd4 ونزولاً على كل الصفوف اي أكثر 17 مليار خلية (عدد سكان الارض ضرب 3) لتبحث من خلاله على خلية واحدة الكود Sub trasnfer_data() Dim DE As Worksheet, D As Worksheet Dim My_ro% Set DE = Sheets("Data Enter"): Set D = Sheets("Data") My_ro = D.Cells(Rows.Count, 3).End(3).Row With D .Cells(2, 1).Resize(My_ro, 64).Interior.ColorIndex = xlNone .Range("C" & My_ro + 1) = DE.[k8] .Range("N" & My_ro + 1) = DE.[k10] .Range("BV" & My_ro + 1) = DE.[k12] .Range("BM" & My_ro + 1) = DE.[k14] 'ok '============================= .Range("F" & My_ro + 1) = DE.[I16] .Range("Br" & My_ro + 1) = DE.[O16] .Range("E" & My_ro + 1) = DE.[AD6] '=========================== .Range("R" & My_ro + 1) = DE.[Af8] .Range("D" & My_ro + 1) = DE.[AD10] .Range("Q" & My_ro + 1) = DE.[ad12] .Range("G" & My_ro + 1) = DE.[ad14] .Range("J" & My_ro + 1) = DE.[ad16] .Cells(My_ro + 1, 1).Resize(, 64).Interior.ColorIndex = 6 End With End Sub الملف My_Salary .xlsm

الكود Option Explicit Sub del_Ranges() Dim my_Srting$: my_Srting = "D5:F35" Dim sh As Worksheet For Each sh In Sheets If sh.Name Like "موظف#*" Then sh.Range(my_Srting).ClearContents End If Next End Sub

في المعادلات التي تكتبها استعمل الفاصلة المنقوطة " ; " بدل الفاصلة العادية " , " هذا يرجع الى اعدادات الــ Office عندك يمكن تغيير هذه الاعددات اذا اردت ذلك مثلاً بدل كتابة (MATCH(A1,$F$1:$F$4,0)= اكتب (MATCH(A1;$F$1:$F$4;0)=

هذه الاسطر من الكود يمكن ازالتها لانها تثقل البرنامج بدون منفعة(كانت للكود القديم) Dim Ar(4), Ar_Fasl(1 To 9) Dim t: t = Sheets(my_SHEET).Index Dim Start_row_B%: Dim Start_row_H% For i = 4 To 12 Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i)) Next Erase Ar: Erase Ar_Fasl

الآن فهمت ما تريده في الخلايا D6 و D7 من كل صفحة بدل الى هذه المعادلة لتضبط الحسابات (تم التبديل) =COUNT($C$10:$C$1100) =COUNT($I$10:$I$1100) الكود من جديد Option Explicit Sub get_Eleves_Names(ByVal my_SHEET As String) Rem ====>>>> Created By Salim Hasbaya On 31/7/2019 Application.ScreenUpdating = False '================================ Dim SH As Worksheet Dim ss% For Each SH In Sheets If SH.Name Like "*#*" Then ss = ss + 1 End If Next Set SH = Nothing '============================ Dim m As Worksheet: Set m = Sheets("Main") Dim But_Sheet As Worksheet: Set But_Sheet = Sheets(my_SHEET) But_Sheet.Range("K1") = ss: ss = 0 Dim Ar(4), Ar_Fasl(1 To 9) Dim t: t = Sheets(my_SHEET).Index Dim Start_row_B%: Dim Start_row_H% Dim mal$: mal = "ذكر" Dim fem$: fem = "انثى" Dim i% Dim RGU As Range: Set RGU = m.Range("v2", Range("v1").End(4)) Dim RGAH As Range: Set RGAH = m.Range("AH2", Range("AH1").End(4)) But_Sheet.Range("B10").Resize(500, 5).ClearContents But_Sheet.Range("H10").Resize(500, 5).ClearContents '======================================= Dim Filtred_rg As Range: Set Filtred_rg = m.Range("a1").CurrentRegion Dim FinaL_row%: FinaL_row = Filtred_rg.Rows.Count For i = 4 To 12 Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i)) Next With Filtred_rg .AutoFilter 2, mal .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("B10") .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("d10") .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("e10") .Columns(17).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("f10") End With But_Sheet.Range("c10").Resize(RGU.Rows.Count).Value = _ RGU.Value '======================================= With Filtred_rg .AutoFilter 2, fem .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("h10") .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("j10") .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("k10") .Columns(17).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(xlCellTypeVisible).Copy But_Sheet.Range("L10") End With But_Sheet.Range("I10").Resize(RGAH.Rows.Count).Value = _ RGAH.Value But_Sheet.Columns("A:L").AutoFit '================================ If Sheets("Main").FilterMode Then _ Sheets("Main").ShowAllData: Filtred_rg.AutoFilter Set m = Nothing: Set But_Sheet = Nothing Erase Ar: Erase Ar_Fasl Application.ScreenUpdating = True End Sub '================================================== Sub EXTACCT_NAME() Dim Impt Dim x% Impt = InputBox("Please Give_me the sheet's name to transfer data" & _ Chr(10) & "Write the sheet's name Without Cotes") If UCase(Impt) = "MAIN" Then MsgBox "I can't Change the values of Principal Sheet" Exit Sub End If On Error Resume Next x = Len(Sheets(Impt).Name) If x = 0 Then On Error GoTo 0 MsgBox "The Sheet: " & Impt & " Not Existes" Exit Sub End If Call get_Eleves_Names(Impt) End Sub الملف الجديد Students_names.xlsm

هات نموذج عما تريد لان الكود سيتعلق بكيفية كتابة الاسماء مثلاً (Employ3,Employ2,Employ1.....) او (محمد ابراهيم محمود.....) من الافضل وضع اسماء الموظفين في جدول خاص في الصفحة الرئيسية في عامود بعيد بعض الشيء لعدم العبث به عن طريق الخطأ مثلاُ العامود ZZ

لم افهم ما تريد الضبط لان هناك في الملف معادلات مع Circular reference لكني اتوقع هذا الكود يفي بالغرض Option Explicit Sub get_Eleves_Names(ByVal my_SHEET As String) Rem ====>>>> Created By Salim Hasbaya On 27/6/2019 Application.ScreenUpdating = False '================================ Dim SH As Worksheet Dim ss% For Each SH In Sheets If SH.Name Like "*#*" Then ss = ss + 1 End If Next Set SH = Nothing '============================ Dim m As Worksheet: Set m = Sheets("Main") Dim But_Sheet As Worksheet: Set But_Sheet = Sheets(my_SHEET) But_Sheet.Range("K1") = ss: ss = 0 Dim Ar(4), Ar_Fasl(1 To 9) Dim t: t = Sheets(my_SHEET).Index Dim Start_row_B%: Dim Start_row_H% Dim mal$: mal = "ذكر" Dim fem$: fem = "انثى" Dim i% Dim lrc%, LrI% But_Sheet.Range("B10").Resize(500, 5).ClearContents But_Sheet.Range("H10").Resize(500, 5).ClearContents '======================================= Dim Filtred_rg As Range: Set Filtred_rg = m.Range("a1").CurrentRegion Dim FinaL_row%: FinaL_row = Filtred_rg.Rows.Count For i = 4 To 12 Ar_Fasl(i - 3) = CStr(But_Sheet.Cells(5, i)) Next With Filtred_rg .AutoFilter 2, mal .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("B10") .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("d10") .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("e10") .Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("f10") lrc = Application.Max(But_Sheet.Range("a:a")) But_Sheet.Range("c10").Resize(lrc) = 1 End With '======================================= With Filtred_rg .AutoFilter 2, fem .Columns(8).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("h10") .Columns(7).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("j10") .Columns(1).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(12).Copy But_Sheet.Range("k10") .Columns(3).Offset(1).Resize(FinaL_row - 1, 1) _ .SpecialCells(xlCellTypeVisible).Copy But_Sheet.Range("L10") LrI = Application.Max(But_Sheet.Range("G:G")) - lrc But_Sheet.Range("i10").Resize(LrI) = 2 End With Start_row_B = But_Sheet.Cells(Rows.Count, "B").End(3).Row Start_row_H = But_Sheet.Cells(Rows.Count, "H").End(3).Row But_Sheet.Columns("A:L").AutoFit '================================ If Sheets("Main").FilterMode Then _ Sheets("Main").ShowAllData: Filtred_rg.AutoFilter Set m = Nothing: Set But_Sheet = Nothing Erase Ar: Erase Ar_Fasl Application.ScreenUpdating = True End Sub '================================================== Sub EXTACCT_NAME() Dim Impt Dim x% Impt = InputBox("Please Give_me the sheet's name to transfer data" & _ Chr(10) & "Write the sheet's name Without Cotes") If UCase(Impt) = "MAIN" Then MsgBox "I can't Change the values of Principal Sheet" Exit Sub End If On Error Resume Next x = Len(Sheets(Impt).Name) If x = 0 Then On Error GoTo 0 MsgBox "The Sheet: " & Impt & " Not Existes" Exit Sub End If Call get_Eleves_Names(Impt) End Sub quawa3em.xlsm

بنعديل بسيط على الكود يمكن عمل هذا

1- قم بتسمية الورقة الرئيسية بغير رقم مثلاً "main_sheet" او اي اسم تختاره 2-قم بتسمية الأوراق التي ترغب بمسح النطاق منها بالارقام مثلاً "1" "2" "15 " الخ.. نفذ هذا الماكرو (ستلاحظ الاوراق التي يحتوي اسمها على كلمات لا يتعاطى معها الماكرو) الماكرو Option Explicit Sub del_Ranges() Dim my_Srting$: my_Srting = "D5:F35" Dim sh As Worksheet For Each sh In Sheets If sh.Name Like "#*" Then sh.Range(my_Srting).ClearContents End If Next End Sub الملف مرفق كنموذج MOURATABAT.xlsm

نطاق الفاتر مؤلف من 10 اعمدة من A الى J لذلك لا يوجد عامود رقم 22

ممكن ان تعمل protect على الخلايا التي تحتوي معادلات فقط وباقي الخلايا تتركها غير محمية هذا الملف مثال على ذلك (الحماية فقط في النطاق الاخضر ) اما باقي الخلايا ان كانت فيها معادلات اولا غير محمية) من خلال الكود يمكنك تغيير حجم النطاق الى ما تريد Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Me.Unprotect Me.Cells.Locked = False Dim My_SELECT As Range Dim CEL As Range Set My_SELECT = Intersect(Range("A1:F7"), Selection) If My_SELECT Is Nothing Then GoTo End_me With Me For Each CEL In My_SELECT If CEL.HasFormula Then With CEL .Locked = True .FormulaHidden = True .Interior.ColorIndex = 6 End With End If Next End With End_me: Me.Protect Application.EnableEvents = True End Sub الملف مرفق Protect_formula.xlsm

الصورة امامك أهو بعد تحديد الخلية (أو الخلايا)المطلوبة اولا اضغط حيث يشير السهم الاسود ثم اختر ما يشير اليه السهم الاخضر الثاني

رداً على استفسار الاخ ناصر المصري حول اختيار قسمين من الاسم (الاول مع الأخير ) يمكنك استعمال المعادلة التالية مع تحديد الارقام X Y لكنها تعطي في بعض الأحيان خطأ اذا اخترت X Y غير مناسبين مثلا: اذا اردت الاسم الأول والثاني تضع 1 مكان X وتضع 2 مكان Y اذا اردت الاسم الأول فقط تضع 1 مكان X وتضع عددا كبيراً بعض الشيء (20) مكان Y اذا اردت الاسم الثاني فقط تضع 2 مكان X وتضع عددا كبيراً بعض الشيء (20) مكان Y =Salim_Split_Name($A2,X) &" "& Salim_Split_Name($A2,Y) تم وضع UDF جديدة لاختيار اي قسمين من الاسم ( الاول مع الأخير الاول مع الثاني أو الثاني مع الأخير الخ..) الصفحة Salim من هذا الملف الأفضل هو استعمال هذه الدالة Fuction_split_Part_name.xlsm

جرب هذا الملف (لغاية 100 اسم ويمكن الزيادة قدر ما تريد) ولا حاجة للفلتر SORT _WITHOU_VBA.xlsx

تظهر هذه العلامة ### في حالتين اما التاريخ اصغر من صفر او الخلية ضيقة لاستيعاب التاريخ لذلك قم بتوسيع العامود قليلاً لترى النتيجة

قم بتغيير التنسيق كما في الصورة

شاهد هذا الفيديو https://www.youtube.com/watch?v=A6bWkE5JVIw

ربما يفيدك هذا الملف ايضاً بعد اذن الاخ وجيه Test.xlsx

جرب هذا الملف بعد اذن اخي علي طبعاً Time_AM_PM.xlsm

يمكنك الاطلاع على احد المواضيع القديمة التي استعملها في المدرسة من خلال هذا الملف working_days.xlsm

لا أعلم اذا كان المطلوب المعادلات محمية فقط من اجل عدم العبث بها عن طريق الخطأ my_test.xlsx

يارك الله فيك اخي علي وهذا كود اخر يعتمد على 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

أولا من اول نظرة لحجم الملف لاحظت انه كبير جدأ حوالي واحد ميغا فمن الطيبعي ان يكون بطيئاً حاول التقليل من التنسيقات الملونة والتنسيقات الشرطية لان كل هذا يؤثر على السرعة الخلايا المدمجة علة العلل و عدو المعادلات والأكواد الأول حاول قدر الامكان التخفيف منها ثانيا لما لا تقوم بتحيمل الكود بشكل يمكن قرائته استعمل اشارة الكود الموجودة في القائمة عنك 1-اضغط اولا على الايقونة <> في الشرط العلوي للمشاركة 2- انسخ الكود الى النافذة التي تظهر 3-اضغط على اضف للمشاركة