سليم حاصبيا

و هل رأيت اي كود في الملف؟؟...

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

جرب هذا الملف صفحة Salim اذا كان صحيحاً انقل المعادلات الى باقي الصفحات Ali_Metw _Electicite.xlsm

هناك موضوع بهذا الشأن على هذا العنوان حمل الملف وقم بتغيير القيم التي تريدها https://www.officena.net/ib/topic/85569-فاتورة-الكهرباء/

أمامنا جدول مع بيانات مختلفة 1- انقر على اي خلية من الجدول (ما عدا رأس الجدول) لتحصل على فلتر بقيمة هذه الخلية 2-انقر على اي خلية ( من رأس الجدول) لتحصل على كل البيانات 3-لإضافة بيانات على الجدول انقر على اول صف فارغ وأملأ الصف كما تشاء (لا يعمل الماكرو الا اذا كان الصف كاملاً ببياناته 4 قيم) ملاحظة: لا يعمل الماكرو Reset ولا الماكرو Make_On_Top كل بمفرده الا من خلال الماكرو الرئيسي SelectionChange الماكرو Option Explicit Dim Lr%, Rng As Range '========================== Sub Make_On_Top() On Error GoTo Exit_Sub Rng.Rows(1).Interior.ColorIndex = 6 With ActiveSheet .Range("z1") = Cells(3, ActiveCell.Column) .Range("z2") = ActiveCell.Value .Range("a3").CurrentRegion.AdvancedFilter 1, Range("z1:z2") .Cells(3, ActiveCell.Column).Interior.ColorIndex = 8 End With Exit_Sub: End Sub '================================== Sub Reset() On Error GoTo Exit_Sub Rng.Rows(1).Interior.ColorIndex = 6 On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 Exit_Sub: End Sub '=========================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Lr = Cells(Rows.Count, 1).End(3).Row Set Rng = Range("A3:D" & Lr) If Not Intersect(Target, Rng) Is Nothing And _ Application.CountA(Range(Cells(Target.Row, 1), _ Cells(Target.Row, 4))) = 4 _ And Target.Cells.Count = 1 Then If Target.Row = 3 Then Reset Else Make_On_Top End If End If Range("z1:z2").Clear End Sub الملف مرفق Super Adv_Filter.xlsm

كيف نجعل الخلية تتمرد على تحديدها و تنتقل مع محتوياتها الى العامود المجاور(هروباً من التحديد) شاهد هذا الملف Go_Away.xlsm

كيف العمل مع ملف بدون بيانات لكن حسب ما فهمت من الموضوع تريد هذا النموذج Translate.xlsm

نعم لائحة أسماء دون تكرار ومرتبة أبجدياً بدون ماكرو ولا فلتر فقط (معادلات) اللائحة تتجاهل الفراغات و الارقام (فقط نصوص) لرؤية المعادلات يكفي رفع الحماية عن الشيت/ بدون كلمة مرور ترتيب ابجدي.xlsx

بعد اذن الاستاذ بن علية كما وعدتكم نفس الملف (بالمعادلات) و في نطاق مطاط (اكثر من صف) Money_translater.xlsx

جرب هذا الملف المعادلة في E6 ,اسحب يميناً =IF($D6="fadi",INDEX({"4 درجات ";"3 درجات";"10 درجات"},MATCH(E$5,{43354;43347;43344},-1)),"") sss.xlsx

لا أعلم إذا كان هذا المطلوب COMMON_ITEM.xlsx

السؤال غير واضح لا ار اي رقم 3 في العامود الثاني

لعنوان يدل على الموضوع مثلا: 250 جنيه ممكن يكونوا: 1- 5 أوراق من فئة 50 جنيه 2- 25 ورقة من فئة 10 جنيه ..... الخ أقل عدد من الاوراق 3 2 من فئة 100 و واحدة من فئة 50 لنرى كيف اكسل يحل هذه المسألة ملاحظة :جاري العمل على نفس الموضوع لكن بواسطة المعادلات دعواتكم بالتوفيق أهم شيء الملف مرفق monney.xlsm

جرب هذا الكود Option Explicit Private Sub Worksheet_change(ByVal Target As Range) If Target.Column = 4 And IsEmpty(Cells(Target.Row, 3)) _ And IsEmpty(Cells(Target.Row, 2)) And Target.Row > 1 Then Application.EnableEvents = False With Target .Offset(, -1) = Date .Offset(, -2) = Time .Offset(, -3) = Target.Row - 1 End With End If Application.EnableEvents = True End Sub الملف مرفق Auto_date.xlsm

ذا اردنا ان تختار مجموعة عشوائية من تلاميذ صف ( بعدد محدد) و ادراج اسمائهم في عامود (دون تكرار) و في عامود اخر ما بيقى منهم اكسل يحل لنا هذا الموضوع بواسطة هذا الملف الكود Option Explicit Sub RANDOM_ELEVES() If ActiveSheet.Name <> "Salim" Then GoTo Exit_Me ActiveSheet.Unprotect With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row Dim x%: x = [h2] Dim y%: y = [h3] If Not IsNumeric(x) Or x < 1 _ Or x Mod 1 <> 0 Or x >= y Then x = Int(y / 2) [h2] = x End If Range("d2", Range("d1").End(xlDown)).ClearContents Range("f2", Range("f1").End(xlDown)).ClearContents Dim My_Rg: Set My_Rg = Range("b2:b" & lr) Dim g() ReDim g(1 To lr) Dim i Dim k%: k = 1 Do Randomize i = Int((lr - 1 + 1) * Rnd + 1) If g(i) = False Then g(i) = i k = k + 1 Cells(k, 4) = My_Rg.Cells(i) End If Loop Until k = [h2] + 1 Range("d2:d" & k).SortSpecial Header:=xlNo k = 2 For i = LBound(g) To UBound(g) If g(i) = vbNullString Then Cells(k, 6) = My_Rg.Cells(i) k = k + 1 End If Next Erase g ActiveSheet.Protect Exit_Me: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف ا Choose_Studiantes.xlsm

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

شاهد هذا الملف SAL_COND.xlsx

جرب هذا الماكرو (على اساس ان البيانات تبدأ من الخلية A1 ) و يتخللها صفوف و أعمدة فارغة Sub del_rows_and_columns() Dim my_rg1 As Range, my_rg2 As Range Dim y%: y = Cells(1, Columns.Count).End(1).Column Dim x%: x = Cells(Rows.Count, 1).End(3).Row Set my_rg1 = Range(Cells(1, 1), Cells(1, y)).SpecialCells(4) Set my_rg2 = Range(Cells(1, 1), Cells(x, 1)).SpecialCells(4) my_rg1.EntireColumn.Delete my_rg2.EntireRow.Delete End Sub

استاذ احمد لم ادرس الاكواد جيداً بعد لكني لاحظت شيئاً ان المستخدم عندما ينفذ كود معين يجب ان يكون في الشيت التي يتبع لها هذا الكود ولا مجال هنا للخطأ لان عملية Undo غير مجدية في الاكواد (ربما يقوم الكود بمسح سجلات غير مرغوب بمسحها) لذا اقترح ان تدرج العبارة التالية في بداية كل كود If ActiveSheet.Name <> "ْXXXXXX" Then Exit Sub مكان XXXXXX تضع اسم الشيت حبث سينفذ الماكرو التقليل قدر المستطاع من استعمال Select التي ترهق البرنامج. مثلا بدل استعمال Sheets("Sheet1").Select Range("a1:a500").Select Range("a1:a500").Copy يكفي Sheets("Sheet1").Range("a1:a500").Copy

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

اتيع الارشادات من هذه الصورة

يمكن هذا الكود يحل المشكلة الكود Option Explicit Sub edit_formula() Application.EnableEvents = False Dim my_rg As Range Dim cel As Range Dim t Dim r% t = Range("a1").Formula Dim lr%: lr = Cells(Rows.Count, 1).End(3).Row On Error Resume Next Set my_rg = Range("a1:a" & lr).SpecialCells(xlCellTypeBlanks) If Err.Number <> 0 Then GoTo 1 On Error GoTo 0 For Each cel In my_rg r = cel.Offset(-1, 0).Row t = Replace(t, "A1", "A" & r + 1) cel.Formula = t t = Range("a1").Formula Next 1: Application.EnableEvents = True End Sub '===================================== Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 Then edit_formula End If End Sub الملف مرفق Auto num.xlsm

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

جرب هذا التعديل Salim_Names_1.xlsm

البيانات عندك كبيرة جداً كان يكفي ارسال بضعة صفوف جرب هذا الملف و قم بتعديل المعادلات لتتناسب مع ما هو موجود عندك taween.xlsx