سليم حاصبيا

جرب هذا الماكرو يوجد صفحة مساعدة مخفية باسم salim Option Explicit Sub filter_for_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Sheets("data2").Range("a7:D5000") .ClearContents .Interior.ColorIndex = 0 End With Dim S_sh As Worksheet: Set S_sh = Sheets("data") Dim T_sh As Worksheet: Set T_sh = Sheets("salim") Dim My_Table As Range: Set My_Table = S_sh.Range("A11").CurrentRegion.Columns("A:F") Dim r1%, m%: m = 7 T_sh.Cells.Clear T_sh.Range("L1") = "الجنس": T_sh.Range("L2") = "H" My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("L1:L2"), _ CopyToRange:=T_sh.Range("A1") T_sh.Range("L1:l2").ClearContents T_sh.Range("C:C,F:F").Delete r1 = T_sh.Range("a1").CurrentRegion.Rows.Count Sheets("Data2").Range("a" & m).Resize(r1 - 1, 4).Value = _ T_sh.Range("a2").Resize(r1 - 1, 4).Value Sheets("Data2").Range("a" & m).Resize(r1 - 1, 4).Interior.ColorIndex = 33 m = m + r1 '==================================== T_sh.Cells.Clear T_sh.Range("L1") = "الجنس": T_sh.Range("L2") = "F" My_Table.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=T_sh.Range("L1:L2"), _ CopyToRange:=T_sh.Range("A1") T_sh.Range("L1:l2").ClearContents T_sh.Range("C:c,F:F").Delete r1 = T_sh.Range("a1").CurrentRegion.Rows.Count Sheets("Data2").Range("a" & m).Resize(r1 - 1, 4).Value = _ T_sh.Range("a2").Resize(r1 - 1, 4).Value Sheets("Data2").Range("a" & m).Resize(r1 - 1, 4).Interior.ColorIndex = 40 T_sh.Cells.Clear '=============================== With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق salim_Book.xlsm

جرب هذا المعادلة =IF(C8<MIN({15;24;35}),"لا عمولة",INDEX({170;240;270},MATCH(C8,{15;24;35}))*C8) الملف مرفق Aumoula.xlsx

استاذ ايهاب خطرت على بالي هذه المعادلة لكن تغاضيت عنها خوفاً من ان اصدار الاكسل عند السائل أقل من 2007

جرب هذا الماكرو (استبدل اسم الشيت إلى salim ) Option Explicit Sub crazy_average() Dim m%, nRow%, nCol%, j%, _ i%, My_Col%, s#, All_col% Dim Rg As Range Dim Answer# With Sheets("salim") With .Range("a2").CurrentRegion nRow = .Rows.Count nCol = .Columns.Count - 1 m = .Cells(1, 1).Row + 1 End With For j = 2 To nRow% For i = 1 To nCol '========================= If .Cells(j, i) <> 0 Then My_Col = .Cells(j, i).Column Set Rg = .Range(Cells(j, My_Col), Cells(j, nCol)) All_col = nCol - IIf(My_Col = 1, 0, My_Col) s = Application.Sum(Rg) Answer = s / IIf(All_col = nCol, nCol, All_col + 1) .Cells(m, nCol + 1) = Answer m = m + 1 Exit For End If '======================== Next Next End With End Sub الملف مرفق Average_special.xlsm

جرب هذا الشيء Percent_.xlsx

نعم هذا الشيء يسرع الماكرو بشكل كبير اليك هذه التجربة في هذا الملف MACRO_SPEED.xlsm

كثر الحديث والطلب عن هذا الموضوع (استخراج الارقام أو الأحرف او الكلمات من نص) لذلك قمت بتحميل هذا الملف الذي عسى ان يستفيد منه اكبر عدد ممكن من الاعضاء الملف يحتوي على دالّة معرفة Option Explicit Function Salim_Single_Match(aString As String, my_expression As String, n%) As Variant Dim RegEx As New VBScript_RegExp_10.RegExp Dim NowArray() As String Dim Match, matches As Object Dim x%, cnt% With RegEx .Pattern = my_expression .Global = True .IgnoreCase = True End With On Error Resume Next Set matches = RegEx.Execute(aString) x = matches.Count If x = 0 Then Error.Clear Salim_Single_Match = "No Match": Exit Function End If ReDim NowArray(x - 1) For Each Match In matches NowArray(cnt) = Match.Value cnt = cnt + 1 Next If n > cnt Then n = cnt Salim_Single_Match = NowArray(n - 1) End Function salim_UDF_Formula.xlsm

بكل تواضع في المدارس يلقبونني بـــ "ملك المعادلات" في أماكن أخرى "Doctor Excel" مع اني لا استحق اي من هذين اللّقبين

ربما تقصد هذا الشيء صفحة Salim من هذا الملف salim_formula_New.xlsm

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

راجع هذا العنوان https://www.officena.net/ib/topic/89773-تعديل-بسيط-في-كود/

لا أفهم لماذا غيرت رأيك أنت من طلب اخر عملية

جرب هذا الماكرو Option Explicit Sub Give_Repport() Dim lr% Application.ScreenUpdating = False Sheets("Control_Me").Cells.Clear With Sheets("main") lr = .Range("A4").End(4).Row - 1 .Range("R5:R" & lr).Formula = "=sum(C5:Q5)" .Range("C" & lr + 1 & ":Q" & lr + 1).Formula = _ "=sum(C5 " & ":C" & lr & ")" .Range("R" & lr + 1).Formula = "=SUM(R5:R" & lr & ")" With .Range("A4:R" & lr + 1) .Value = .Value .Copy Sheets("Control_Me").Range("a4") End With End With Application.ScreenUpdating = True End Sub الملف مرفق Khasm_2.xlsm

ربما ينفع هذا الكود Option Explicit Sub Dive_Last_Row() If ActiveSheet.Name = "الايراد" Then Exit Sub Sheets("الايراد").Range("a3").End(4).Offset(1).Resize(, 3).Value = _ ActiveSheet.Range("a4").End(4).Resize(, 3).Value End Sub الملف مرفق Matrek.xlsm

لا استطيع فهم المطلوب بالنسبة لكود الجمع لا لزوم للحلقات التكرارية يكفي هذا الكود Sub Collection() Range("k2:K" & Range("A" & Rows.Count) _ .End(xlUp).Row).Formula = "=SUM(A2:F2)" End Sub

(لا يمكن العمل مع هكذا جداول التي تحتوي على عدو المعادات والأكود اللدود( أعني الخلايا المدمجة لان اكسل لا يستطيع قراءة جدول بالشكل الصحيح مع خلايا مدمجة (الصفوف 16/17/18 و 26/27/28 من الورقة Feuil1) يجب ترتيب الجدول أولاً كما يظهر في الورقة Salim من هذا الملف (لا خلايا مدمجة داخل الجدول / فوق الجدول و تحته صف فارغ عن يمينه ويساره عامود فارغ) الجدول من الخلية A14 الى الخلية S26 Excel_table.xlsx

الخطأ هنا 32 يا شاطر و ليس 31 ,$B$23:$B$32))*(FIND(B14,$B$23:$B$31))*(SEARCH("Inspection",$B$23:$B$31)))

عندما لا تعمل المعادلة يكون هناك نقص في المعطيات مثلاً مسافة زائدة /مسافة ناقصة /غلط املائي بالكتاية/حرف كبير او صغير الـــخ.... لذلك لا تعتمد على الكتابة اليدوية (استعمل طريقة Copy Paste) بدون مسافات زئدة او ناقصة

هي العلامة الادنى التي يجب الحصول عليها كي يعتبر التلميذ ناجحاً انا اعتبرتها 10 ولك حرية التغيير

لايجاد الحل لا يمكن التخمين ماذا تريد بدون ملف مرفق مع ذلك اليك هذا الملف كنموذج (يعمل حتى 100 اسم و يمكن الزيادة) Male_Femal_Dup.xlsx

لم تذكر علامة النجاح لذلك تركتها لك اختيارياً percent.xlsx

Try this file complex_formula.xlsx

رائع استاذ بن علية لكن اذا كنت تريد نقل التنسيق ايضاً يمكن استعمال هذا الكود حلقة تكرارية واحدة (ربما يكون أسرع للبيانات الكبيرة) مع امكانية ادراج صف فارغ أو لا (بعد نسخ البيانات) من خلال الاجابة عن سؤال Yes Or No Option Explicit Sub All_in_on_New() With Sheets("Sheet1") Dim my_rg As Range, N_col%, x% Dim k%: k = 2 Dim sub_rg As Range Dim Answer As Byte .Range("j2:j" & Rows.Count).Clear Set my_rg = .Range("a2").CurrentRegion N_col = my_rg.Columns.Count Answer = MsgBox(" Your Data With Empty Row Between Or NO??", 4) For x = 1 To N_col Set sub_rg = my_rg.Columns(x).SpecialCells(2, 23) sub_rg.Copy Cells(k, "j") k = k + sub_rg.Cells.Count + (7 - Answer) Next End With End Sub الملف مرفق Write_in_one_co_New.xlsm

جرب هذا الماكرو Option Explicit Sub All_in_on() With Sheets("sheet1") Dim my_rg As Range, N_col%, N_Row%, x% Dim t%, k%: k = 2 Set my_rg = .Range("a2").CurrentRegion .Range("j2", Range("j1").End(4)).ClearContents N_col = my_rg.Columns.Count N_Row = my_rg.Rows.Count For x = 1 To N_col For t = 1 To N_Row If Not IsEmpty(my_rg.Cells(t, x)) Then .Cells(k, "J") = my_rg.Cells(t, x) k = k + 1 End If Next Next End With End Sub الملف مرفق Write_in_one_col.xlsm

الملف مع الكود أضغط فقط على الزر Click_Me Mars.xlsm