سليم حاصبيا

هذه المعادلة في الخلية O4 واسحب نزولاً قيمة الحسم تكتب في الخلية S2 الدالة ( 5 , )CEILLNG لتقريب الرقم الى مضاعفات الرقم 5 =IF(N(D4)<=0,"",CHOOSE(((B4<>"")*(D4<>1)*(C4>=3))+1,0,CEILING(N4*($S$2/100),5))) الملف مرفق discount_salim.xlsx

في حصائص الزر ضع PrintObject=False

حتّى لا يضيع الــ Commend Button أو اذا قمت بتحديد نطاق من الخلايا (او حتى خلية واحدة) بعيداً عنه فأنه يتبعك اينما ذهبت بواسطة هذا الكود Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim col%: col = Target.Columns.Count Dim lastcel As Range: Set lastcel = Target.Rows(1).Cells(col) Application.EnableEvents = False With Me.Shapes.Range(Array("SALIM_BTN")) .Left = lastcel.Left + lastcel.Columns.Width + 5 .Top = lastcel.Top .Width = 130 .Height = 28 End With Application.EnableEvents = True End Sub جرب هذا الملف Floting_Btn.xlsm

استبدل الكود بهذا (هذا الكود يعمل اينما كانت الاوراق غير المرغوبة) Option Explicit Sub Give_ALL_Data() Dim Arr_sh(), i%, m%: m = 2 Dim Arr_counte(), k%: k = 1 For i = 1 To Sheets.Count If InStr(Sheets(i).Name, "شهر") Then ReDim Preserve Arr_sh(1 To k) ReDim Preserve Arr_counte(1 To k) Arr_sh(k) = Sheets(i).Name Arr_counte(k) = Application.Max(Sheets(i).Range("a:a")) k = k + 1 End If Next Sheets("تجميع").Range("b2:i500").ClearContents For i = LBound(Arr_sh) To UBound(Arr_sh) Sheets("تجميع").Range("b" & m).Resize(Arr_counte(i), 8).Value = _ Sheets(Arr_sh(i)).Range("b2").Resize(Arr_counte(i), 8).Value m = m + Arr_counte(i) + 1 Next Erase Arr_sh: Erase Arr_counte End Sub او استبدل في الكود القديم هذا السطر (شرط وجود الاوراق غير المرغوبة في الأخر) For i = 1 To Sheets.Count-1 بهذا For i = 1 To Sheets.Count-3 الملف مرفق Tajmi3.xlsm

يمكن عمل ذلك بواسطة كود (الصفحة SALIM من هذا الملف) Option Explicit Sub colorize() With Sheets("SALIM") Dim cl As Long, Lastcol As Long, Lastrow As Long Lastcol = .Cells(4, Columns.Count).End(1).Column - 1 Lastrow = .Cells(Rows.Count, 3).End(3).Row Range("c4").Resize(Lastrow - 3, Lastcol).Interior.ColorIndex = xlNo Dim n#, RO%, k%, m% For RO = 4 To Lastrow For m = 3 To Lastcol n = .Cells(RO, m) k = Application.CountIf(Cells(RO, m).Resize(, 7), n) If k = 7 Then .Cells(RO, m).Resize(, 7).Interior.ColorIndex = 28 m = m + 6 End If Next Next End With End Sub الملف مرفق تنسيق شرطي by_VBA .xlsm

ممكن جمع الشيتات التي تريد في Array والتعديل في الكود كما تشاء

من باب الحفاظ على حقوق النشر والملكية الفكرية يجب ذكر واضع الكود للملف الذي قمت برفعه جرب هذا الكود Option Explicit Sub Give_ALL_Data() Dim Arr_sh(), i%, m%: m = 2 Dim Arr_counte() For i = 1 To Sheets.Count - 1 ReDim Preserve Arr_sh(1 To i) ReDim Preserve Arr_counte(1 To i) Arr_sh(i) = Sheets(i).Name Arr_counte(i) = Application.Max(Sheets(i).Range("a:a")) Next Sheets("تجميع").Range("b2:i500").ClearContents For i = LBound(Arr_sh) To UBound(Arr_sh) Sheets("تجميع").Range("b" & m).Resize(Arr_counte(i), 8).Value = _ Sheets(Arr_sh(i)).Range("b2").Resize(Arr_counte(i), 8).Value m = m + Arr_counte(i) + 1 Next Erase Arr_sh: Erase Arr_counte End Sub الملف مرفق Data_from_all_sheets.xlsm

كود ممتاز و أرجو ان تتقبل مني هذه الملاحظلات: 1 - من الخطأ ان تحدد المتغير n_rows كاخر صف في العامود D من الصفحة ws لانه ممكن ان يكون عامود اخر غير D أطول باليبانات (أقصد اخر خلية غير فارغة فيه موجودة في صف اكبر من n_rows) لذلك بجب ان تأخذ اكبر عدد ممكن (أنا اخذت 50 و ممكن أكثر ) "" اذا اردت يمكن تحديد العامود الذي يملك اكبر اخر صف (بواسطة سطرين بنفس الكود) و تعمل على اساسه"" 2- من الضروري جداً وضع عبارة Option Explicit في بداية أي كود تقوم بكتابته ،لأن هذه العبارة توقف الكود عن النتفيذ اذا كان هناك اي خطأ في اي متغير مثلاً (تم الاعلان عن متغير My _cell ب Dim وفي احد الاماكن من الكود تم كتابة My_ cel ) Only l) فإن الكود يتوقف و تظهر لك رسالة مع تحدديد الحطأ باللون الازرق) 3- عدا عن ذلك بوجود Option Explicit يمكن الاسراع بكتابة الكود لان مجرد كتابة اول حرف او حرفين من اسم المتغير و الضفط على مفتاح Ctrl+ المسافة تظهر لك لائحة بالمتغيرات لتختار ماذا تريد 4- أخيراً بوجود Option Explicit فإن الكود يرفض التعامل مع اي متغير لم يتم الاعلان عنه بواسطة Dim للمزيد شاهد هذا الفيديو https://www.youtube.com/watch?v=nKgF9tA-8gc

أرجو رفع الكود بعد التعديل لعل أحد من الأعضاء يستفيد منه

استبدل اسم الصفحة"حاسب " الى "Haseb" ونفذ هذا الكود الاكسل عنده حساسية للغة العربية لذلك أفضل ان تكون اسماء الصفحات باللغة الاجنبية Option Explicit Sub sum_from_Other_sheet() Dim source_sh As Worksheet: Set source_sh = Sheets("salim") Dim target_sh As Worksheet: Set target_sh = Sheets("Haseb") Dim i: i = 5 Dim k%, xx%, n_rows%: n_rows = 50 Dim s# With source_sh Do Until .Cells(i, 1) = vbNullString k = Application.Match(.Cells(i, 1), target_sh.Rows(3), 0) For xx = 4 To n_rows If IsNumeric(target_sh.Cells(xx, k)) Then s = s + target_sh.Cells(xx, k) End If Next .Cells(i, 1).Offset(, 1) = s s = 0: i = i + 1 Loop End With End Sub

جرب هذا الكود النتائج في الورقة salim Option Explicit Private Sub Salim_Com_Click() With Sheets("salim") Dim c% Combo_Salim.Clear c = 5 Do Until Cells(c, 1) = vbNullString Combo_Salim.AddItem .Cells(c, 1) c = c + 1 Loop End With End Sub '============================== Sub Add_Sum() With Sheets("salim") ''''''''''''''''''''''''' With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With .Range("b5", Range("b4").End(4)).ClearContents Dim s#, k%, r%, i%: i = 5 Do Until .Cells(i, 1) = vbNullString k = Application.Match(.Cells(i, 1), Rows(3), 0) For r = 4 To 50 If IsNumeric(.Cells(r, k)) Then _ s = s + .Cells(r, k) Next .Cells(i, 1).Offset(, 1) = s s = 0 i = i + 1 Loop ''''''''''''''''''''''''' End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق salim_sum_new.xlsm

جرب هذا الملف salim_sum.xlsm

انا شخصياً كنت زيك مفتكر ان الاكسل مش اكثر من جدول وشوية كده هوو معادلات ضرب وجمع... إلى ان غطست في هذا البحر (لا بل المحيط الهائل) و ما زلت بكل تواضع لا اعرف (حسب تقديري) اكثر من 10% من المعلومات حول هذا البرنامج كل شيء اعرفه تم اكتسابه 1-بواسطة مشاهدة الفيديوهات (لم اتعلمه اكاديمياً في معهد أو جامعة) 2- التجارب التي أقوم بها على الاكسل يعجبني قول احد الشّعراء قل لمن يدّعي بالعلم معرفةً عرفت شيئاً و غابت عنك أشياءُ

جرب هذا الملف تم انشاء 12 ورقة تنقل اليها البيانات قبل ان تغير الشّهر Option Explicit Sub Give_Data() Dim st As String st = Sheets("Sheet3").Range("b7").Value Dim my_sh As Worksheet Set my_sh = Sheets(st) With my_sh .Cells.ClearContents .Range("d2").Resize(34, 32).Value = _ Sheets("Sheet3").Range("d2").Resize(34, 32).Value .Range("e4").Resize(, 31).NumberFormat = "ddd" .Range("e5").Resize(, 31).NumberFormat = "d" End With End Sub '============================================== 'janvier , février, mars, avril, mai, juin, juillet, aout, septembre, octobre, novmbre, decembre Sub sheets_name() Dim arr(1 To 12) Dim i% arr(1) = "janvier": arr(2) = "février": arr(3) = "mars" arr(4) = "avril": arr(5) = "mai": arr(6) = "juin" arr(7) = "juillet": arr(8) = "aout": arr(9) = "septembre" arr(10) = "octobre": arr(11) = "novmbre": arr(12) = "decembre" For i = 2 To 13 Sheets(i).Name = arr(i - 1) Next End Sub الملف مرفق présence_salim.xlsm

استبدل هذه الاسطر من الكود Dim m%: m = 3: Dim Col%: Col = 5 Dim R%, T% بهذه Dim m as Long: m = 3: Dim Col as Long: Col = 5 Dim R as Long, T as Long لقد وضعت لك طريقة بواسطة المعادلات في مشاركة سابقة (في هذا الملف) لكن المشكلة أن البيانات كبيرة جداً (حواليي 5000 صف)مما يستغرق وقتاً كبيراً check_Salim1.xlsx

تم معالجة الأمر الماكرو لا يعمل اذا لم يكن الفلتر موجوداً أو اذا لم تكن الورقة الاولى هي النّاشطة بعد تنفيذ الماكرو تمسح البيانات التي تم نقلها من الورقة الاولى Sub Salim() If ActiveSheet.Name <> "Sheet1" Or _ Sheets("sheet1").AutoFilterMode = False Then Exit Sub If Sheets(1).[c4] = vbNullString Then Exit Sub Dim lr%, lr1% lr = Sheets(1).Range("a" & Rows.Count).End(xlUp).Row If lr <= 5 Then MsgBox "No Data to Transfer", 64 Exit Sub End If lr1 = Sheets(Sheets(1).[c4].Value) _ .Cells(Rows.Count, 1).End(3).Row + 2 If lr1 = 7 Then lr1 = 6 Sheets(1).Range("a6").Resize(lr - 5, 14).SpecialCells(12) _ .Cut Sheets(Sheets(1).[c4].Value).Range("a" & lr1) Sheets(1).Range("a6").Resize(lr - 5, 14).SpecialCells(4).EntireRow.Delete Sheets("sheet1").AutoFilterMode = False End Sub الملف من جديد Tarhil_by_filter.xlsm

الملف الذي أرسلته معقد جداً لذا قمت بوضع ملف جديد مشابه لما تريد البيانات في الشيت 1 و النتيجة في الشيت2 الكود Option Explicit Sub eXtract_Data() Dim s_rg As Range Dim first$ Dim r%, c%, x r = 1: c = 1 Sheets("Sheet2").Range("a1").CurrentRegion.ClearContents Set s_rg = Sheets("Sheet1").Range("My_Rg").Find("*", _ after:=Sheets("Sheet1").Range("My_Rg").Cells(1, 1)) If Not s_rg Is Nothing Then first = s_rg.Address Do Sheet2.Cells(r, c) = s_rg.Value c = c + 1 If c = 9 Then r = r + 1: c = 1 End If Set s_rg = Sheets("Sheet1").Range("My_Rg").FindNext(s_rg) If s_rg.Address = first Then Exit Do Loop End If End Sub الملف مرفق saerch_and_copy.xlsm

هذا الماكرو يقوم بما تريدين اختي الفاضلة Option Explicit Sub lena() If Sheets(1).[c4] = vbNullString Then Exit Sub Dim lr%, lr1% lr = Range("a" & Rows.Count).End(xlUp).Row If lr <= 5 Then MsgBox "No Data to Transfer", 64 Exit Sub End If lr1 = Sheets(Sheets(1).[c4].Value) _ .Cells(Rows.Count, 1).End(3).Row + 2 Sheets(1).Range("a6").Resize(lr - 5, 14) _ .Cut Sheets(Sheets(1).[c4].Value).Range("a" & lr1) End Sub

يجب كتابة الدالة المناسبة لها باللغة الفرنسية

بالضبط هذه و في عامود التقييم هذه المعادلة أسهل من كل هذه الشروط المتكررة IF =VLOOKUP(H5,{0,"نتائج ضعيفة جدا";7,"نتائج غيرمقبولة";10,"نتائج متوسطة";11,"نتائج حسنة";13,"نتائج جيدة جدا";15,"نتائج ممتازة"},2)

هذه المعادلة في عامود المعدل =IF(COUNTBLANK(D6:G6)=0,CEILING(SUM(D6:G6)/5,0.25),"")

الكود طويل جداً و يحتوي على أكثر من مـرة SELECT & COPY & PASTE هذا الاوامر ترهق الاكسل ولا لزوم لاستعمالها الا عند الضرورة اليك هذا الكود البسبط Option Explicit Sub copy_data() If ActiveSheet.Name <> "Sheet1" Then Exit Sub Dim R%, R1% R = Cells(Rows.Count, 3).End(3).Row + 1 R1 = Range("K5", Range("K4").End(4)).Resize(, 6).Rows.Count Cells(R, 3).Resize(R1, 6).Value = _ Range("K5", Range("K4").End(4)).Resize(, 6).Value Cells(R, 3).Resize(R1, 6).SpecialCells(4) = "EMPTY CELL" End Sub الملف مرفق فقط اضغط الزر للتنفيذ Samer Book.xlsm

عندما تكتب الاسماء صحيحة يضبط النتسيق

المشكلة عندك لا يمكن ان يكون في نفس الصف ثلاث اشخاص أو أكثر بنفس الاسم استعمل الملف الذي رفعته لك سابقاً واستبدل الاسماء المستعارة A1 A2 .... بالاسماء عندك Choose_grade.xlsm

بارك الله بك أخ علي لكني أفضل هذه المعادلة في حال ادراج نص أو رقم سالب او كانت الخلية فارغة (يظهر فراغ) =IF(N(A2)<=0,"",YEAR(INT(A2)))