سليم حاصبيا

يمكن ذلك تفضل نموذج الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim My_word My_word = [f2] Application.EnableEvents = False If Not IsNumeric([f2]) Then My_word = UCase([f2]) '======================================= If ((Not Intersect(Target, Range("b:b")) Is Nothing) Or Target.Address = "$A$1") And UCase([a1]) = My_word Then Range("b:b") = vbNullString End If '=================================== Else '======================================= If ((Not Intersect(Target, Range("b:b")) Is Nothing) Or Target.Address = "$A$1") And [a1] = My_word Then Range("b:b") = vbNullString End If '=================================== End If Application.EnableEvents = True End Sub No_writing In BB.rar

اليك هذا النموذج No_writing in A1.rar

جرب هذا الماكرو Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim OldVal Application.EnableEvents = False OldVal = [b1] If (Target.Address = "$B$1" Or Target.Address = "$A$1") And [a1] = 1 Then [b1] = "" Else [b1] = OldVal End If Application.EnableEvents = True End Sub

ممكن ان يكون المطلوب انظر الى الصفحة Salim Ghonaim1 Salim.rar

بعد اذن الاستاذ محمد تدرج في الخلية I2قائمة منسدلة تحتوي على كلمتين نقدي و تقسبط ثم هذه المعادلة في D5 =IF(B5="","",CHOOSE(($I$2="نقدي")+1,VLOOKUP($B5,'اسم المادة والسعر'!$B$2:$D$999,2,0),VLOOKUP($B5,'اسم المادة والسعر'!$B$2:$D$999,3,0))) الملف مرفق choose Price Salim.rar

استاذ محمد كود رائع بسيط و معبّر بارك الله بك و باعمالك لكن عندما قيل لي ا ن الاعمدة متحركة في الجدول (تارة يريد البيانات في العامود AR وطوراً في غيره) اضطررت الى اعداد الكود الذي ادرجته في مشاركتي

هناك دالة تقوم بهذا العمل اسمها FLOOR( اسنعمل احد الدالتين حسب اعدادات الجهاز عندك) =FLOOR(A1,5) أو =FLOOR(A1;5)

تم معالجة الامر الشرح داخل الملف Boook1 Salim.rar

اضف 1 أو 2 إو اي رقم تريد على المعادلة لتصبح هكذا: =IF(B2="","",SUBTOTAL(103,$B$2:B2)+1)

مع انك لم ترفق ملفاً للعمل عليه اجمل لك هذا الملف كتموذج عما تريد BiDA3A.rar

بعد اذن اخي ياسر هذا الكود Option Explicit Option Base 1 Sub Give_Uniques() Dim j, x As Integer Dim First_Sh, Sec_Sh As Worksheet Dim sn Dim Obj As Object Set First_Sh = Sheets("بيانات الطلبة"): Set Sec_Sh = Sheets("اوائل ") sn = First_Sh.Range("v7:v" & Cells(Rows.Count, "v").End(xlUp).Row) With CreateObject("System.Collections.ArrayList") For j = 1 To UBound(sn) If sn(j, 1) <> vbNullString Then If Not .Contains(sn(j, 1)) Then .Add sn(j, 1): x = x + 1 End If Next .Sort Sec_Sh.Range("s9").Resize(x) = Application.Transpose(.toarray) End With End Sub

هذا لاني اضفت كما قلت لك عدد من الصفوف قبل الصف 3 فإصبحت البيانات تبدأ من الصف رقم 6 ( ملفكم الأخير faux وجدت أنه بعد اضافة موظف يصبح ترقيمه الجديد دائما مضاف اليه عدد 4 ...مثلا عوض أنه يكون ترقيمه 10 ..يرقمه الملف بـ 14) أخبرك اني فعلت ذلك خصيصاً كي ترى الفرق (هنا تكمن المشكلة كما شرحت لك سابقاً ) أنظر الى هذا الملف من فضلك الذي لا يتأثر ياضافة الصفوف او حذفها Auto_Numeration.rar

في الخلية A1 اكتب هذه المعادلة ثم اسحبها نزولاً الى اي مكان تريد =IF(B1="","",SUBTOTAL(103,$B$1:B1))

ربما يكون المطلوب 55 salim.rar

أخي ابو تقوى للاسف لا يعمل كما يحب اعيد لك الملف مع تعديل بسيط(قمت يزيادة بضعة صفوف ) جربه الآن ترقيم تلقائي Faux.rar

لا يمكن اخفاء خلايا في اكسل انما صفوف او اعمدة

تم التعديل على الكود بدون تفريغ العامود H انظر الى الصفحة salim الكود مرفق (لعدم اظهار المجموع للعامود I) يمكن تعطيل السطر الاخير من الكود (قبل End Sub) و ذلك بكتابة فاصلة عليا في بدايته الكود: Option Explicit Sub extract_data() Dim My_Rg, Cel As Range Dim Roow, Cool As Integer Dim StrJ, StrI, StrH As String Dim OldVal If ActiveSheet.Name <> "salim" Then Exit Sub StrJ = "=D2-I2": StrJ = Replace(StrJ, Chr(34), Chr(34) & Chr(34)) StrI = "=SUM(E2:G2)": StrH = Replace(StrI, Chr(34), Chr(34) & Chr(34)) StrH = "=IF(j2="","",MOD(j2,1))": StrH = Replace(StrH, Chr(34), Chr(34) & Chr(34)) Set My_Rg = Sheets("salim").Range("A1").CurrentRegion Roow = My_Rg.Rows.Count Cool = My_Rg.Columns.Count Set My_Rg = My_Rg.Offset(1).Resize(Roow - 1).Offset(0, Cool - 3).Resize(Roow - 1, 3) ' My_Rg.Select '//////////////////////////////////////////////////////////// My_Rg.Columns(2).Cells(1).Resize(Roow - 1).Formula = StrI My_Rg.Columns(3).Cells(1).Resize(Roow - 1).Formula = StrJ My_Rg.Columns(1).Cells(1).Resize(Roow - 1).Formula = StrH '========================================== OldVal = My_Rg.Columns(1).Cells(1).Resize(Roow - 1).Value '============================================== For Each Cel In My_Rg.Columns(2).Cells(1).Resize(Roow - 1) Cel.Value = Cel.Value + Cel.Offset(0, -1).Value Next '====================================== My_Rg.Columns(1).Cells(1).Resize(Roow - 1) = OldVal My_Rg.Columns(1).Cells(1).Resize(Roow - 1).Offset(Roow).Cells(1) = Application.Sum(OldVal) '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ End Sub كسرالقرش معدل.rar

ربما كان هذا ما تقصده اذا كان اكثر من اسم لها نفس البيانات اكسل يوردها كلها (و يتم تلوينها) طالب Salim.rar

استعمل هذه المعادلة للحد الادنى والثانية للحد الاقصى (Ctrl+Shift+Enter) و ليس Enter وحدها =MIN(IF($E$8:$E$18=$F$5,$D$8:$D$18)) =MAX(IF($E$8:$E$18=$F$5,$D$8:$D$18))

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

بواسطة المعادلات لا تستطيع عمل ذلك لانك تقع في مشكلة Circular Reference تم التعديل على الماكرو لاظهار الفرق في العامود I و جمعه كسرالقرش SalimA.rar

جرب هذه الملف يجب ان يكون العامودين H & L (حدود جدول النتائج) فارغين كي بعمل الكود بشكل جيد كسرالقرش Salim.rar

تم تغيير الكود(انسخه الى موديل جديد و عين له زراً للتنفيذ) Option Explicit Option Base 1 Sub Salim_Extract() Dim Src_Sh As Worksheet Dim Trg_Sh As Worksheet Dim xx, lr, m, My_Row As Integer Dim ArrJ(), ArrG() Dim t As Long Application.ScreenUpdating = False My_Row = 4 Set Trg_Sh = Sheets("الديون") Trg_Sh.Range("e4").Resize(10000, 3).Clear For m = 3 To Sheets.Count - 2 t = 1 Set Src_Sh = Sheets(m) With Src_Sh .Select On Error GoTo 1 On Error Resume Next lr = .Cells(Rows.Count, "j").End(3).Row For xx = 4 To lr If .Cells(xx, "j") > 0 And Cells(xx, "j") <> "" Then ReDim Preserve ArrJ(t) ReDim Preserve ArrG(t) ArrJ(t) = .Cells(xx, "j").Value ArrG(t) = .Cells(xx, "G").Value: t = t + 1 End If Next End With Trg_Sh.Range("g" & My_Row).Resize(UBound(ArrJ)) = Application.Transpose(ArrJ) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)) = Application.Transpose(ArrG) Trg_Sh.Range("e" & My_Row).Resize(UBound(ArrG)) = Sheets(m).Cells(1, 2) Trg_Sh.Range("f" & My_Row).Resize(UBound(ArrG)).NumberFormat = "m/d/yyyy" My_Row = My_Row + t Trg_Sh.Range("e" & My_Row - 1).Resize(, 3).Interior.ColorIndex = 6 1: Erase ArrJ: Erase ArrG Next Application.ScreenUpdating = True Trg_Sh.Activate: Range("e3").Select End Sub الملف المرفق اصنافform salim 1.rar

تستطيع حشر الموظف اينما تريد و ذلك بكتابة الرقم المطلوب في الخلية i2 و كتابة اسمه فقط و ثم الضفط على الزر تستطع ايضاً كتابة اسماء متشابهة شرط ان يكون الشهرة مختلفة(مثلاً كمال يوسف و كمال محمود -لا مشكلة) اذا سجلت رقماً اكبر من اكبر رقم في اللائحة وقتها يضيف اكسل الاسم بعد الاسم الاخير

اخي ياسر يوجد حل لهذا الامر قاعدة البيانات salim.rar