سليم حاصبيا

شاهد هذا الفيديو الدقيقة 10 : 2 https://edu.gcfglobal.org/en/excel2013/sorting-data/1/

كاسم المستلم مثلا او المستلم + المشروع معا لم أر المستلم ولا المشروع في الجدول فهل المستلم هو المستفيد والمشروع هو الموقع ام بالعكس جرب هذا الملف (صفحة One For_All ) الملف مرفق Option Explicit Dim DC As Object Dim DD As Object Dim D_Sh As Object Dim O As Worksheet Dim sh As Worksheet Dim i, Max_ro%, m% '++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() data_val End Sub '++++++++++++++++++++++++++ Sub MY_choose() Select Case Sheets("One For_All").Range("G2") Case "E": Filter_Only_E Case "D": Filter_Only_D Case "D+E": Filter_C_And_D Case Else: Exit Sub End Select End Sub '++++++++++++++++++++ Sub data_val() Set O = Sheets("One For_All") Set DC = CreateObject("Scripting.Dictionary") Set DD = CreateObject("Scripting.Dictionary") Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row For i = 2 To Max_ro DC(Sheets("Payments").Cells(i, "C").Value) = vbNullString DD(Sheets("Payments").Cells(i, "D").Value) = vbNullString Next With O.Range("D2").Validation .Delete .Add 3, Formula1:=Join(DC.keys, ",") End With With O.Range("E2").Validation .Delete .Add 3, Formula1:=Join(DD.keys, ",") End With End Sub '+++++++++++++++++++++++++++ Sub Filter_Only_E() Set O = Sheets("One For_All") If O.Range("C4").CurrentRegion.Rows.Count > 1 Then O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion. _ Rows.Count - 1).Clear End If Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row m = 5 If O.Range("E2") = vbNullString Then Exit Sub For i = 2 To Max_ro If Sheets("Payments").Cells(i, "D") = O.Range("E2") Then O.Cells(m, 3) = m - 4 O.Cells(m, 4).Resize(, 5).Value = _ Sheets("Payments").Cells(i, 2).Resize(, 5).Value m = m + 1 End If Next If O.Range("C4").CurrentRegion.Rows.Count > 1 Then With O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .InsertIndent 1 End With End If End Sub '+++++++++++++++++++++++++++++++++++ Sub Filter_Only_D() Set O = Sheets("One For_All") If O.Range("C4").CurrentRegion.Rows.Count > 1 Then O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion. _ Rows.Count - 1).Clear End If Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row m = 5 If O.Range("D2") = vbNullString Then Exit Sub For i = 2 To Max_ro If Sheets("Payments").Cells(i, "C") = O.Range("D2") Then O.Cells(m, 3) = m - 4 O.Cells(m, 4).Resize(, 5).Value = _ Sheets("Payments").Cells(i, 2).Resize(, 5).Value m = m + 1 End If Next If O.Range("C4").CurrentRegion.Rows.Count > 1 Then With O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .InsertIndent 1 End With End If End Sub '++++++++++++++++++++ Sub Filter_C_And_D() Set O = Sheets("One For_All") If O.Range("C4").CurrentRegion.Rows.Count > 1 Then O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion. _ Rows.Count - 1).Clear End If Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row m = 5 If O.Range("D2") = vbNullString Or _ O.Range("E2") = vbNullString Then Exit Sub For i = 2 To Max_ro If Sheets("Payments").Cells(i, "C") = O.Range("D2") And _ Sheets("Payments").Cells(i, "D") = O.Range("E2") Then O.Cells(m, 3) = m - 4 O.Cells(m, 4).Resize(, 5).Value = _ Sheets("Payments").Cells(i, 2).Resize(, 5).Value m = m + 1 End If Next If O.Range("C4").CurrentRegion.Rows.Count > 1 Then With O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .InsertIndent 1 End With End If End Sub Hisabat_Super.xlsm

ألف مبروك تستحقانها عن جدارة

الملف يجب ان يكون هكذا (75 كيلو بايت لا أكثر) Hisabat.xlsx

Payments!$B$1:$B$65536 كيف تريد ان لا يكون الملف ثقيلاُ وانت تستعمل في 6 صفجات في كل منها حوالي 100 معادلة وكل معادلة تبحث في 65536 صف اي ما مجموعه 65556×100×6 = اكثر من 40 مليون معادلة (مضروبة بــ 2 لأن البرنامج يعطي نتيجتين لكل معادلة أو الجواب صجيجاً او فراغ اذا كانت النتيجة خطأ) و هكذا الاكسل يقوم بأكثر من 80 مليون عملية حسابية مع كل ضغطة زر من الكيبورد او نقرة من الماوس كل هذا بالاضافة الى التنسيقات التي تقوم لها من تلوين بألوان مختلفة يزيد من ثقل الملف على الرغم من قلة البيانات فيه (الاكسل معذور في هذه الحالة) خفف المعادلات من حيث عدد الصفوف (اجعلها مثلاُ 1500 بدل 65536)

للمرة الألف (اختصار البيانات للتحقق من عمل الكود) الكود الي يعمل على صف واحد يمكنه العمل على الالوف منها هذا الماكرو Option Explicit Sub Merged_Sum() Dim ro, i% ro = Cells(Rows.Count, 2).End(3).Row Dim n% With Range("D6:D" & ro) .ClearContents .Interior.ColorIndex = xlNone End With For i = 6 To ro If Val(Cells(i, 3)) <> 0 Then n = Cells(i, 2).MergeArea.Rows.Count With Cells(i, 4) .Value = Application.Sum(Cells(i, 3).Resize(n)) .Interior.ColorIndex = 6 End With i = i + n - 1 End If Next End Sub الملف مرفق Naser.xlsm

المشكلة كانت هنا (الصورة) النطاق من E3 الى Z3 لا يجب ان بكون فارغاً (للمحافظة على تنسيق الحدول) ضع فيه أي شيء (مثلاً انا وصعت الاعداد من 1 الى 22 بتنسيق احفاء) الملف مرفق من جدبد Moustsfa_New.xlsm

جر ب هذا الماكرو (الترقيم يتم دون زيادة أو نقصان) اذا اردت الغاء الترقيم احذف السطر داخل المربع الأحمر من الكود (الصورة) Option Explicit Sub my_Macro() Dim D As Worksheet Dim i%, x%, ky, ro% Dim Rg As Range Dim Dic As Object With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set D = Sheets("Data") Set Rg = D.Range("A3").CurrentRegion If Rg.Rows.Count = 1 Then GoTo Bay_Bay Set Dic = CreateObject("Scripting.Dictionary") For i = 4 To Rg.Rows.Count + 2 Dic(D.Cells(i, "AA").Value) = "" Next x = 1 If Dic.Count Then For Each ky In Dic.keys ro = Sheets(CStr(x)).Range("A3").CurrentRegion.Rows.Count If ro > 1 Then Sheets(CStr(x)).Range("A3").CurrentRegion. _ Offset(1).Resize(ro - 1).Clear End If Rg.AutoFilter 27, ky D.Range("B4").Resize(Rg.Rows.Count - 1, 3) _ .SpecialCells(12).Copy Sheets(CStr(x)).Range("B4").PasteSpecial (12) D.Range("AA4").Resize(Rg.Rows.Count - 1) _ .SpecialCells(12).Copy Sheets(CStr(x)).Range("E4").PasteSpecial (12) ro = Sheets(CStr(x)).Range("A3").CurrentRegion.Rows.Count If ro > 1 Then With Sheets(CStr(x)).Range("A3").CurrentRegion. _ Offset(1).Resize(ro - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Cells(1, 1).Resize(ro - 1) = _ Evaluate("row(1:" & ro - 1 & ")") End With End If x = x + 1 Next End If Bay_Bay: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With D.AutoFilterMode = False End Sub الملف مرفق Moustsfa.xlsm

جربي هذا الملف كلما نريدين مجموعة اضغطي عل الزر Run code Option Explicit Sub Arkam_3ashwa3iat() Dim Formule$ Range("A3:C6").Formula = _ "=RANDBETWEEN(1,$E3/3)" Range("A3:C6").Value = _ Range("A3:C6").Value Formule = "=IF(SUM($A3:$C3)>$E3,SUM($A3:$C3)-E3," Formule = Formule & "IF(SUM($A3:$C3)<" Formule = Formule & "$E3,$E3-SUM($A3:$C3),0))" Range("D3").Resize(4).Formula = Formule Range("D3").Resize(4).Value = _ Range("D3").Resize(4).Value End Sub Zahra.xlsm

ربما يكون الحل Function Salim_Extract(Txt$, Patt$, Optional Itm = 1) Dim Regex As Object Dim My_match As Object On Error GoTo Bay_Bay Set Regex = CreateObject("VBScript.RegExp") With Regex .Pattern = Patt .Global = True End With If Regex.test(Txt) Then Set My_match = Regex.Execute(Txt) Salim_Extract = My_match(Itm - 1) Exit Function End If Bay_Bay: Salim_Extract = "" End Function الملف مرفق Mostafa Moawad.xlsm

جرب هذا الماكرو لعله يكون المطلوب (فقط اصغط الزر Run ) Option Explicit Sub Text_to_date() Dim st, i%, m%, k%, ro Dim arr() Dim My_dat As Date Dim stg ro = Cells(Rows.Count, 1).End(3).Row If ro < 2 Then Exit Sub Range("C2:C" & ro).ClearContents For i = 2 To ro st = Split(Cells(i, 1)) For k = LBound(st) To UBound(st) If st(k) <> "" Then ReDim Preserve arr(m) arr(m) = st(k) m = m + 1 End If Next k On Error Resume Next stg = """" & arr(2) * 1 & " " & arr(0) & " " & arr(1) * 1 & """" If Err.Number > 0 Then GoTo Next_I If IsDate(Evaluate(stg)) Then My_dat = Evaluate(stg) Cells(i, 3) = My_dat End If Next_I: Erase arr: m = 0: On Error GoTo 0 Next i End Sub الملف مرفق Text_to dat.xlsm

تم التعديل الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Rg As Range, F_rg As Range Application.EnableEvents = False Set Rg = Union(Range("C3:C20"), Range("E3:E20"), Range("G3:G20")) If Not Intersect(Target, Rg) Is Nothing _ And Target.Cells.Count = 1 Then Set F_rg = Range("B42:B57").Find(Target, lookat:=1) If Not F_rg Is Nothing Then Target = Cells(F_rg.Row, "C") End If End If Application.EnableEvents = True End Sub Talal_1.xlsm

البيانات في الغمود A هي مجرد نصوص و ليس تواريخ الصورة توضح ذلك

مسألة سهلة كثيراً باستعمال الدالة IF لذلك سأتركها لأحد الأعضاء المبتدئين كي يتدرّب عليها

تفضل تم ازالة الألوان الفاقعة التي تيهر البصر بمجرد النظر اليها الكود يعمل في النطاق من A3 الى A20 Talal.xlsm

جرب هذه المعادلة معادلة صفيف اي يجب الضفط على (Crtl+Shift+Entr) وليس (Enter) وحدها =SUM(IF(ISNUMBER(SEARCH(TRIM($A$3:$A$7),TRIM(A11))),$B$3:$B$7,0)) الملف مرفق Mox.xlsx

لك ما تريد My_tax_1.xlsm

انت طلبت ( أما اذا زاد عن 11000) على كل جال تعديل بسيط بالماكرو مكان 11000> نضع 11000=>

و هذا ما يفعله الماكرو انظر الى القيمة 9000 في الجدول (Other Examples)

يمكن جمعهم اينما نريد الصورة توضح ذلك

تم معالجة الأمر Option Explicit Function Salim_Tax(Myfact As Double, _ n1 As Double, n2 As Double, _ n3 As Double, n4 As Double) As Double '''''''''''''''''''''''''''''''''''''''''' Dim A#, B#, C#, D#, E#, S# Select Case True Case Myfact < 11000 A = Myfact * n1 S = A Case Myfact < 18500 B = 11000 * n2 C = (Myfact - 11000) * n3 S = (B + C) * 0.55 Case Else 'Exact B = 11000 * n2 C = 7500 * n3 D = (Myfact - 18500) * n4 S = (B + C + D) * 0.925 End Select Salim_Tax = Round(S, 2) End Function My_tax.xlsm

بعد اذن الاح بن علية يمكن حساب ذلك بواسطة دالة تعريف (UDF) الدالة المعرفة Option Explicit Function Salim_Dariba(Myfact As Double, _ n1 As Double, n2 As Double, _ n3 As Double, n4 As Double) As Double '''''''''''''''''''''''''''''''''''''''''' Dim How_Many Select Case Myfact Case Is <= 11000 How_Many = Myfact * n1 Case Is <= 18500 How_Many = (11000 * n1) + (Myfact - 11000) * n2 Case Is <= 26000 How_Many = (11000 * n1) + (7500 * n2) + (Myfact - 18500) * n3 Case Is > 26000 How_Many = _ (11000 * n1) + (7500 * n2) + (7500 * n3) + (Myfact - 26000) * n4 End Select Salim_Dariba = How_Many '''''''''''''''''''''''''''''''''''''''' End Function الملف مرفق مع مثال Dariba.xlsm

الكود يعمل مع اي عدد من الشيتات 1-المهم وجود الشيت Result 2 _ ان تكون الييانات في نطاق واحد من كل شبت ( ابتداءٍ من الخلية A2 ) و بدون صفوف فارغة

جرب هذا الكود اذا لم تظهر القائمة المنسدلة (في الشيت Result) غادر الصفجة ثم عد اليها مجدداً Ihab.xlsm

قليل من التنسيق الاصافي بجيث يظهر لك مكان وجود الرصيد (اسم الشيت) مع تلوينه باللون الاصفر في الشيت Option Explicit Sub get_data() Dim Inf As Worksheet Dim sh As Worksheet Dim OBJ As Object Dim OBJ_name As Object Dim S_rg As Range Dim first_row%, sec_row%, m% Dim max_ro%, Arr, ky Dim iNCLR As Range, iNCLR_RO% Set OBJ = CreateObject("Scripting.Dictionary") Set OBJ_name = CreateObject("Scripting.Dictionary") Set Inf = Sheets("Info") '+++++++++++++++++++++++++++++ For Each sh In Sheets If sh.Name <> Inf.Name Then Set iNCLR = sh.Range("B2").CurrentRegion iNCLR_RO = iNCLR.Rows.Count If iNCLR_RO > 2 Then iNCLR.Offset(2).Resize(iNCLR_RO - 2). _ Interior.ColorIndex = xlNone End If End If Next '++++++++++++++++++++++++++++++++ max_ro = Inf.Range("B2").CurrentRegion.Rows.Count If max_ro > 2 Then Inf.Range("B2").CurrentRegion. _ Offset(2).Resize(max_ro - 2).Clear End If If Inf.Range("J1") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> Inf.Name Then Set S_rg = sh.Range("C:C").Find(Inf.Range("J1"), lookat:=1) If Not S_rg Is Nothing Then first_row = S_rg.Row: sec_row = first_row Do sh.Cells(sec_row, 2).Resize(, 7) _ .Interior.ColorIndex = 6 Arr = sh.Cells(sec_row, 3).Resize(, 6) Arr = Application.Transpose(Arr) Arr = Application.Transpose(Arr) OBJ(OBJ.Count) = Join(Arr, "*") OBJ_name(OBJ_name.Count) = sh.Name Set S_rg = sh.Range("C:C").FindNext(S_rg) sec_row = S_rg.Row If sec_row = first_row Then Exit Do Loop End If 'find End If 'name Next 'sh m = 3 If OBJ.Count Then For Each ky In OBJ.keys With Inf.Cells(m, 3) .Resize(, 6) = Split(OBJ(ky), "*") .Offset(, -1) = m - 2 .Offset(, 6) = OBJ_name.Item(m - 3) m = m + 1 End With Next With Inf.Range("B3").Resize(m - 2, 8) .Value = .Value .Columns(5).Formula = "=SUM(D3,-E3)" .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 19 .Value = .Value End With Inf.Cells(m, 2) = "المجموع" Inf.Cells(m, 4).Resize(, 3).Formula = _ "=SUM(D3:D" & m - 1 & ")" Inf.Range("B" & m).Resize(, 7). _ VerticalAlignment = 2 Inf.Cells(m, 2).Resize(, 2). _ HorizontalAlignment = 7 With Inf.Range("B" & m).Resize(, 8) .Value = .Value .Interior.ColorIndex = 35 End With Else MsgBox "This Name Not Exists" End If End Sub الملف من جديد Sandook_NEW.xlsm