سليم حاصبيا

تم التعديل (عند اضاقة اي صتف سوف يرحل تلقائياُ) مع بياناته و يتم تصفير البيانات من جديد Option Explicit Sub Transfere() Dim X, y Dim old_val1#, New_vaL1# Dim old_val2#, New_vaL2# Dim i%: i = 3 Dim My_row%: My_row = Sheets("Sheet2").Cells(Rows.Count, 2).End(3).Row If My_row <= 2 Then Exit Sub Sheets("Sheet1").Range("a4:b" & Rows.Count).ClearContents Sheets("Sheet1").Range("a4").Resize(My_row - 2, 2).Value = _ Sheets("Sheet2").Range("a3").Resize(My_row - 2, 2).Value Do Until Sheets("Sheet2").Range("b" & i) = vbNullString X = Application.Match(Sheets("Sheet2").Range("b" & i), Sheets("sheet1").Range("B:B"), 0) New_vaL1 = Sheets("Sheet2").Range("b" & i).Offset(, 1) New_vaL2 = Sheets("Sheet2").Range("b" & i).Offset(, 2) y = Application.Match(Sheets("sheet2").Range("c1"), Sheets("sheet1").Rows("1"), 0) old_val1 = Sheets("sheet1").Cells(X, y): old_val2 = Sheets("sheet1").Cells(X, y + 1) Sheets("sheet1").Cells(X, y) = old_val1 + New_vaL1 Sheets("sheet1").Cells(X, y + 1) = old_val2 + New_vaL2 Sheets("Sheet2").Range("b" & i).Offset(, 1) = vbNullString Sheets("Sheet2").Range("b" & i).Offset(, 2) = vbNullString i = i + 1 Loop End Sub الملف الجديد مرفق Salim_Magazine_Auto.xlsm

حرب الملف المرفق نسبة مئوية.xlsx

جرب هذا الماكرو Option Explicit Sub Transfere() Dim X, y Dim old_val1#, New_vaL1# Dim old_val2#, New_vaL2# Dim i% i = 3 Dim k% Do Until Sheets("Sheet2").Range("b" & i) = "" X = Application.Match(Sheets("Sheet2").Range("b" & i), Sheets("sheet1").Range("B:B"), 0) New_vaL1 = Sheets("Sheet2").Range("b" & i).Offset(, 1) New_vaL2 = Sheets("Sheet2").Range("b" & i).Offset(, 2) y = Application.Match(Sheets("sheet2").Range("c1"), Sheets("sheet1").Rows("1"), 0) old_val1 = Sheets("sheet1").Cells(X, y): old_val2 = Sheets("sheet1").Cells(X, y + 1) Sheets("sheet1").Cells(X, y) = old_val1 + New_vaL1 Sheets("sheet1").Cells(X, y + 1) = old_val2 + New_vaL2 i = i + 1 Loop End Sub الملف مرفق Salim_Magazine.xlsm

شاهد هذا الفيديو https://support.office.com/en-us/article/video-create-and-manage-drop-down-lists-28db87b6-725f-49d7-9b29-ab4bc56cefc2

تم التعديل(لم انتبه لهذا الشيء) example _salim1.xlsx

جرب هذا الملف example _salim.xlsx

جرب هذا الماكرو Option Explicit Sub speciale_sum() Dim x%: x = 53 Dim k%, col%: col = 23 Dim i%, s# With Sheets("Sheet1") For i = 5 To x For k = 3 To col If .Cells(i, k).Interior.ColorIndex = 2 _ Then s = s + Cells(i, k) Next .Cells(i, col + 3) = s s = 0 Next End With End Sub الملف مرفق Cond_sum.xls

الصورة لا تعطي نتيجة اذ لا يمكن التعامل معها من ناحية الجسابات والتحليل لذلك قم بتحميل البرنامج نفسه للنظر فيه و امكانية اجراء التعديلات اذا كان يحتاج لذلك

هذا الماكرو تضعه في حدث الصغحة ملاحظة: (لا يقوم الماكرو بالعمل الا اذا كانت ال 6 حلايا من ِA الى F غير فارغة) Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Dim First_row% First_row = Application.CountA(Range("A4:A296")) + 4 If Target.Row = First_row - 1 And _ Application.CountA(Cells(Target.Row, 1).Resize(, 6)) = 6 Then Rows("4:296").Hidden = False Rows(First_row + 1 & ":" & 296).Hidden = True End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub الملف مرفق TEST_Salim.xlsm

ربما يكون المطلوب الخامس معدل.xlsm

لا استطيع فهم ما تريد بالضبط رجاء ارسل ملفاً(مختصراً) توضح فيه المطلوب

تنسبق الخلايا الى General

اختصر في التحميل لا يجوز تحميل ملف يحجم 5 ميغا من أجل معادلة

تم ازالة الخلية المرتبطة لانه لا علاقة لها بالكود Combo_with first_Letters1.xlsm

جرب هذا الملف الكود Option Explicit Dim My_list As Object Dim arr Sub fil_combo() Dim Rng As Range, rcell As Range Dim X Set My_list = CreateObject("System.Collections.Arraylist") Set Rng = Sheet1.Range("A5", Sheet1.Cells(Rows.Count, 1).End(xlUp)) Sheet1.ComBo_1.Clear For Each rcell In Rng.Cells X = ComBo_1.Text If Not My_list.Contains(rcell.Text) _ And Mid(rcell, 1, Len(X)) = X Then My_list.Add (rcell.Value) Next rcell My_list.Sort arr = My_list.ToArray End Sub '============================== Private Sub ComBo_1_Change() fil_combo ComBo_1.list = arr ComBo_1.DropDown End Sub Combo_with first_Letters.xlsm

مع انك لم ترفع ملفاً للمعاينة اليك هذا النموذج Ramadan.xlsx

ممتاز اخي علي لكن عتدي ملاحظة بالنسبة للمعادلة فى العامود AB يمكن اختصارها بهذه دون هذه الشروط الكثيرة من IF و AND =VLOOKUP(Z4,{0,"ضعيف";0.5,"مقبول";0.6,"جيد";0.8,"جيد جداً";0.95,"ممتاز"},2)

تم التعديل عل الملف حسابsalim1 .xlsm

لا أعلم بالصبط اذا كان هذا المطلوب حسابsalim.xlsm

بمادا تريد استبدالها ام تريد حذفها على كل حال جرب هذا الملف Book_salim.xlsx

ارفع الملف نفسه وليس صورة عنه اذ لا يمكن التعامل مع صورة

لا أعلم اذا كان المطلوب هنا For Ahmad.xlsm

جرب هذا الماكرو لتفقيط العلامات Tafqitt_3alamat.xlsm

ملف اخر بالمعادلات بعد اذن الاخ علي طبعاً انظر الى الصفحة Salim _formula My_table1.xlsm

جرب هذا الشيء الكود Option Explicit Sub transform_To_Table() With Salim Dim My_rg As Range Dim I%, R%, Col%, M%: M = 5 Dim ro%: ro = 5 Col = .[M2] .Range("e5").CurrentRegion.ClearContents R = .Cells(Rows.Count, 1).End(3).Row For I = 2 To Range("a2:a" & R).Rows.Count - 1 .Cells(ro, M) = .Range("a" & I) M = M + 1 If M > Col + 4 Then M = 5: ro = ro + 1 Next End With End Sub الملف مرفق My_table.xlsm