سليم حاصبيا

جرب هذا الملف sal_test 1.xlsx

ربما كان المطلوب Trakiyat.xlsx

هل ترى ملف بحجم 44.8 هو ثقيل بصراحة لم افهم ماذا تريد بالضبط حاول تعبئة عامود واحد ببيانات متوقعة (يدوياً)

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

ان ما تراه في صفوف الحتياط هو رقم الاستاذ وليس رقم القاعة للمزيد والتأكد هذا الملف من جديد مع (تعديل بسيط في الكود) ليظهر لك اسماء الاساتذة الاحتياط Option Explicit Sub For_matloub_2(col) 'Created by_salim 23/11/2019 'this code distribute teachers randomly Dim i%, m%, x%, k% Dim MY_max%, ro% Dim st$ m = 8 Dim minn%: minn = 1 Dim maxx% Dim arr1(), arr2() Dim how_many Dim myArrayList As Object, myArrayList2 As Object MY_max = Cells(Rows.Count, 2).End(3).Row If Not IsNumeric([E2]) _ Or [E2] < 1 Or [E2] > 18 Then maxx = 18 Else maxx = Int([E2]) End If how_many = maxx - minn + 1 Range(col & 8, Range(col & 7).End(4)).ClearContents Set myArrayList = CreateObject("System.Collections.ArrayList") For i = 1 To maxx - minn + 1 myArrayList.Add Rnd(i) Next arr1() = myArrayList.toarray Set myArrayList2 = myArrayList.Clone myArrayList2.Sort arr2() = myArrayList2.toarray For i = LBound(arr2) To UBound(arr2) If i > how_many - 1 Then Exit For x = Application.Match(arr2(i), arr1, 0) Range(col & m) = _ IIf(m > MY_max - [f2], "احتياط :" & Cells(x + minn + 6, 3), Cells(x + minn + 6, 3)) m = m + 1 Next Set myArrayList = Nothing: Erase arr1 Set myArrayList2 = Nothing: Erase arr2 End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub EXTARCT_for_matloub_2() Dim arr, tt% arr = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", "M") For tt = LBound(arr) To UBound(arr) Call For_matloub_2(arr(tt)) Next Erase arr End Sub الملف للمرة الثالثة Exam _new.xlsm

في الخلية D2 هذه المعادلة وتسحب نزولاً =CHOOSE((A2=C2)+1,B2-A2,0) في الخلية E2 هذه المعادلة وتسحب نزولاً =CHOOSE((A2=C2)+1,$B$1,$C$1) الملف مرفق OLD_NEW_RATEB.xlsx

تم اضافة ماكرو للعمل على صفحة المطلوب 2 مع اضافة الاحتياط (باللون العادي) والأصليين باللون الأزرق الماكرو للصفحة المطلوب 2 Option Explicit Sub N_rand_For_matloub_2(col) 'Created by_salim 23/11/2019 'this code distribute teachers randomly Dim i%, m%, x%, k% Dim MY_max%, ro%, S_Rg As Range m = 8 Dim minn%: minn = 1 Dim maxx% Dim arr1(), arr2() Dim how_many Dim myArrayList As Object, myArrayList2 As Object MY_max = Cells(Rows.Count, 2).End(3).Row If Not IsNumeric([E2]) _ Or [E2] < 1 Or [E2] > 18 Then maxx = 18 Else maxx = Int([E2]) End If how_many = maxx - minn + 1 Range(col & 8, Range(col & 7).End(4)).ClearContents Set myArrayList = CreateObject("System.Collections.ArrayList") For i = 1 To maxx - minn + 1 myArrayList.Add Rnd(i) Next arr1() = myArrayList.toarray Set myArrayList2 = myArrayList.Clone myArrayList2.Sort arr2() = myArrayList2.toarray For i = LBound(arr2) To UBound(arr2) If i > how_many - 1 Then Exit For x = Application.Match(arr2(i), arr1, 0) Range(col & m) = x + minn - 1: m = m + 1 If m > MY_max - [f2] Then GoTo Exit_Me Next Exit_Me: '+++++++++++++++++++++++++++++++++++ For ro = 8 To MY_max Set S_Rg = Range(col & 8).Resize(maxx).Find(Cells(ro, 1), lookat:=1) If S_Rg Is Nothing Then Range(col & m) = "احتياط :" & Cells(ro, 1): m = m + 1 Next '++++++++++++++++++++++++++++++++++ Set myArrayList = Nothing: Erase arr1 Set myArrayList2 = Nothing: Erase arr2 End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub test_for_matloub_2() Dim arr, tt% arr = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", "M") For tt = LBound(arr) To UBound(arr) Call N_rand_For_matloub_2(arr(tt)) Next Erase arr End Sub الملف من جديد Exam 1_2_new.xlsm

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

قم بتعديل هذا السطر في الكود For k = 1 To 3 الى هذا For k = 1 To [f2]

جرب هذا الماكرو Option Explicit Sub N_rand_numbers_Between(col) 'Created by_salim 23/11/2019 'this code distribute teachers randomly Dim i%, m%, x%, k% m = 8 Dim minn%: minn = 1 Dim maxx%: maxx = [d2] Dim arr1(), arr2() Dim myArrayList As Object, myArrayList2 As Object Dim how_many If Not IsNumeric([d2]) _ Or [d2] < 1 _ Or [d2] > maxx - minn + 1 Then how_many = maxx - minn + 1 Else how_many = Int([d2]) End If Range(col & 8, Range(col & 7).End(4)).ClearContents For k = 1 To 3 Set myArrayList = CreateObject("System.Collections.ArrayList") For i = 1 To maxx - minn + 1 myArrayList.Add Rnd(i) Next arr1() = myArrayList.toarray Set myArrayList2 = myArrayList.Clone myArrayList2.Sort arr2() = myArrayList2.toarray For i = LBound(arr2) To UBound(arr2) If i > how_many - 1 Then Exit For x = Application.Match(arr2(i), arr1, 0) Range(col & m) = x + minn - 1: m = m + 1 Next Next Set myArrayList = Nothing: Erase arr1 Set myArrayList2 = Nothing: Erase arr2 End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub test() Dim arr, tt% arr = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", "M") For tt = LBound(arr) To UBound(arr) Call N_rand_numbers_Between(arr(tt)) Next Erase arr End Sub الملف مرفق ضغطة واحدة على زر Run يتم التبديل كل مرة Exam 1_2.xlsm

انا لا افهم ما لزوم الحلقات التكرارية في الكود وهي التي تجعل الملف ثقيلاُ (2000 حلقة) يكفي هذا الماكرو Sub SALIM() Application.ScreenUpdating = False Dim ws As Worksheet Set ws = Worksheets("min") Dim Ro_D%, Ro_A% Ro_D = Cells(Rows.Count, "D").End(3).Row Ro_A = Cells(Rows.Count, "A").End(3).Row With ws .Range("g:f").ClearContents .Cells(2, "f").Resize(Ro_D - 1).Formula = _ "=INDEX($J$2:$J$2000,MATCH(D2,$I$2:$I$2000,0))" .Cells(2, "G").Resize(Ro_A - 1).Formula = _ "=INDEX($Q$1:$Q$6,MATCH(A2,$P$1:$P$6,0))" .Range("g:f").Value = .Range("g:f").Value End With Application.ScreenUpdating = True End Sub

أمر بسيط جداً بواسطة التعديل على الماكرو في الاسطر مابين علامات الـــ+ ++++ ليبدو الماكرو هكذا Option Explicit Sub get_moulahaza() Dim Dic_Name As Object Dim Dic As Object Dim i%, Ro%, ky Ro = Cells(Rows.Count, 2).End(3).Row '+++++++++++++++++++++++++++++++++++++++++ Range("j4").CurrentRegion.Offset(2).ClearContents '+++++++++++++++++++++++++++++++++++++++++ Set Dic_Name = CreateObject("Scripting.Dictionary") Set Dic = CreateObject("Scripting.Dictionary") '============================= '++++++++++++++++++++++++++++++++++ For i = 2 To Ro Dic_Name(Cells(i, 2).Value) = Cells(i, 1).Value Next '++++++++++++++++++++++++++++++++++ '============================= For Each ky In Dic_Name.Keys For i = 2 To Ro If Cells(i, 4) <> "حاضر" And Cells(i, 2) = ky Then If Not Dic.Exists(Cells(i, 2).Value) Then Dic.Add Cells(i, 2).Value, _ Cells(i, 4) & " " & Cells(i, 3) Else Dic(Cells(i, 2).Value) = _ Dic(Cells(i, 2).Value) & " * " & _ Cells(i, 4).Value & " " & Cells(i, 3) End If End If Next i Next ky With Dic Cells(4, "K").Resize(.Count) = _ Application.Transpose(.Keys) Cells(4, "L").Resize(.Count) = _ Application.Transpose(.items) End With '++++++++++++++++++++++++++++++++++++++++++ Cells(4, "J").Resize(Dic_Name.Count) = _ Application.Transpose(Dic_Name.items) '++++++++++++++++++++++++++++++++++++++++++ Set Dic_Name = Nothing: Set Dic = Nothing End Sub الملف من جديد Exampl_moulahaza_new.xlsm

جرب هذا الماكرو Option Explicit Sub get_moulahaza() Dim Dic_Name As Object Dim Dic As Object Dim i%, Ro%, ky Ro = Cells(Rows.Count, 2).End(3).Row Range("j4").CurrentRegion.Offset(2, 1).ClearContents Set Dic_Name = CreateObject("Scripting.Dictionary") Set Dic = CreateObject("Scripting.Dictionary") '============================= For i = 2 To Ro Dic_Name(Cells(i, 2).Value) = vbNullString Next '============================= For Each ky In Dic_Name.Keys For i = 2 To Ro If Cells(i, 4) <> "حاضر" And Cells(i, 2) = ky Then If Not Dic.Exists(Cells(i, 2).Value) Then Dic.Add Cells(i, 2).Value, _ Cells(i, 4) & " " & Cells(i, 3) Else Dic(Cells(i, 2).Value) = _ Dic(Cells(i, 2).Value) & " * " & _ Cells(i, 4).Value & " " & Cells(i, 3) End If End If Next i Next ky With Dic Cells(4, "K").Resize(.Count) = _ Application.Transpose(.Keys) Cells(4, "L").Resize(.Count) = _ Application.Transpose(.Items) End With Set Dic_Name = Nothing: Set Dic = Nothing End Sub الملف مرفق مع الكود Exampl_moulahaza.xlsm

تم معاجة الامر عليك اكمال الجدول في الصفحة الاولى بالاسعار المناسبة من الى تستطيع عدم ذكر العكس مثلا من جدة الى الرياض دون كتابة من الرياض الى جدة (المعادلات تعمل حتى الصف رقم 100) Prices_new.xlsx

هناك سؤال قبل البدء بالعمل هل سعر الرحلات من الى والرحلات المعكوسة هي نفسها (يعني من جدة الى الرياض مثلاً 300 هل يجب ان تكون من الرياض الى جدة 300 ايصاً)

العامود الاول في صفحة Exchange Rate ليس تاريخ بل هو نص على شكل تاريخ

تم عمل المطلوب وجود الخلايا الفارغة في الجدول يسبب هذه المشكلة ttt_new.xlsm

يجب ان تكون الجداول (من إلى ) مكتملة كي تظهر كل النتائج نموذج بسيط عما تريد ان تعرفه Prices.xlsx

جرب هذه المعادلة في الخلية AI6 واسحب نزولاً =CHOOSE((COUNTIFS(D6:AH6,"P")=0)+1,COUNTIFS(D6:AH6,"P"),"") و هذه المعادلة في الخلية AJ6 واسحب نزولاً =CHOOSE((COUNTIFS(D6:AH6,"A")=0)+1,COUNTIFS(D6:AH6,"A"),"") الملف مرفق New_Book1.xlsx

هناك مشاركة مشابهة على هذا العنوان https://www.officena.net/ib/topic/98199-إزالة-علامة-الصفر/?tab=comments#comment-597779

لا يمكن العمل على صورة ولا احد يقوم بوضع ملف لك يحتوي على بيانات كما تريدها ولا يمكن العمل على التخمين لذا رفع الملف او جزء منه اذا كان كبيراً من الضروريات أو سيتم حذف السؤال

ربما يكون المطلوب TEST_new.xlsm

جرب الملف التالي TEST_3.xlsx

جرب هذا الملف Boook1.xlsx

لك ما تريد NO_ZEROS.xlsx