سليم حاصبيا

الملف لا يحتوي على اي ماكرو لانه بصيغة xlsx للحفاظ على الماكرو يجب تحميله بصيغة xlsm

لم افهم السؤال جدياً ما معنى (ترجع الى الاصل) ربما هذا الملف ينفع كمثال Merge_UnMerge Similar_cells.xlsm

جرب هذا الماكرو Option Explicit Sub No_merge() Dim Rg As Range, My_Cell As Range Dim My_val, n%, m% Set Rg = Range("B4:I9").CurrentRegion For Each My_Cell In Rg If My_Cell.MergeCells Then My_val = My_Cell.Value n = My_Cell.MergeArea.Rows.Count m = My_Cell.MergeArea.Columns.Count My_Cell.UnMerge With My_Cell.Resize(n, m) .Value = My_val .Borders.LineStyle = 1 End With End If Next My_Cell End Sub DEl_Merge.xlsm

اذا كنت تريده بالماكرو جرب هذا الشيء Option Explicit Sub Get_Date() Dim x As Long, y As Long, t As Long, Interval Application.ScreenUpdating = False With Sheets("Sheet1") If .Range("B1").CurrentRegion.Rows.Count > 1 Then _ .Range("B1").CurrentRegion.Offset(1).Clear '+++++++++++++++++++++++++++++++++++++++++++ .Shapes.Range(Array("Button 1")).Select Selection.Characters.Text = " Click Please" '+++++++++++++++++++++++++++++++++++++++ If Not IsDate(.Range("E1")) Or _ Not IsDate(.Range("G1")) Then Application.ScreenUpdating = True: Exit Sub x = Application.Min(.Range("E1"), Range("G1")) y = Application.Max(.Range("E1"), Range("G1")) Interval = "Row(" & x & ":" & y & ")" .Range("B2").Resize(y - x + 1) = Evaluate(Interval) .Range("B1").CurrentRegion.NumberFormat = "[$-ar-lb]ddd d mmm yyyy" 'The following Lines of code between the (+) Sign Are Optional _ You can Stop it by typing an "," Before each '+++++++++++++++++++++++++++++++++++++++++++++++ t = .Range("B1").CurrentRegion.CurrentRegion.Rows.Count With .Range("B1").CurrentRegion.Offset(1).Resize(t - 1) .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 16 .Interior.ColorIndex = 19 End With .Shapes.Range(Array("Button 1")).Select Selection.Characters.Text = y - x + 1 & " Days at All" '+++++++++++++++++++++++++++++++++++++++++++ .Cells(1, 1).Select End With Application.ScreenUpdating = True End Sub الملف مرفق List Interval_Of Days.xlsm

جرب هذا الماكرو Option Explicit Sub No_Duplicates() Dim Dic As Object Dim Mmax%, i% Dim SH As Worksheet Set SH = Sheets("Sheet1") Set Dic = CreateObject("Scripting.Dictionary") With SH If .Range("E1").CurrentRegion.Rows.Count > 1 Then _ Range("E1").CurrentRegion.Offset(1).ClearContents Mmax = .Cells(Rows.Count, 1).End(3).Row i = 2 Do Until i > Mmax If .Cells(i, 1) <> vbNullString Then If Not Dic.exists(.Cells(i, 1).Value) Then Dic(.Cells(i, 1).Value) = IIf(IsNumeric(.Cells(i, 2)), _ .Cells(i, 2), 0) Else Dic(.Cells(i, 1).Value) = _ Dic(.Cells(i, 1).Value) + _ IIf(IsNumeric(.Cells(i, 2)), _ .Cells(i, 2), 0) End If End If i = i + 1 Loop If Dic.Count Then .Range("e2").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) .Range("F2").Resize(Dic.Count) = _ Application.Transpose(Dic.items()) End If End With End Sub الملف مرفق No_tekrar.xlsm

يا صديقي انت تقوم بتنفيذ الماكرو على صفحة فارغة (لأن الماكرو يعمل فقط في صفحة Taksim من اجل عدم المساس في البيانات في صفحة اخرى عن طريق الخطأ ) و كما ترى الصفحة Taksim فارغة في الملف المرفق يقوم الكود بنسخ الداتا من صفحة salim الى صفحة Taksim ثم يقوم بترتيبها حسب الرقم في الخلية S2 من الصفحة Taksim لذلك اذا اردت تعديل او اضافة او حذف شيء ما قم بذلك في الصفحة الاولى (salim) ثم اذهب الى الصفحة الثانية (Taksim) ونفذ الماكرو بالضغط على الزر مرفق ملف مع بعض التعدبلات البسيطة Talsim_by_10.xlsm

تم معالجة الأمر Total__Super_1.xlsm

أنا أفصد ارفام الأعمدة المطلوبة في شيت المصدر لا في شيت النتيجة

بدل اعطاء البيانات والتفتيش عنها داخل الورقة اذكر الأعمدة المطلوب نقلها (مثلاً عامود B عامود C الخ.... )

تم التعديل Sub Salim_Total_new() If ActiveSheet.Name <> "Taksim" Then Exit Sub k = [S2]: My_Sum = "SUM OF :" & k Application.ScreenUpdating = False lr1 = [A9999].End(xlUp).Row Cells(lr1 + 2, 1).EntireRow.Delete Start_Row = 2 Last_Sum = lr1 - 2 'start row for the sum sm_n = Int(Last_Sum / k) + 1 'Number of the sum_lines On Error Resume Next '============================= Range("L3:L" & lr1).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete '============================ On Error GoTo 0 lr = [A9999].End(xlUp).Row For i = 1 To sm_n X = k + Start_Row ' X is end row for the sum If X > (lr + 1) Then X = lr + 1: k = X - Start_Row lr = lr + 1 Rows(X).Rows.Insert Shift:=xlDown Cells(X, "L") = My_Sum Cells(X, "M").Resize(, 4).FormulaR1C1 = "=SUM(R[-" & k & "]C:R[-1]C)" Cells(X, "O") = vbNullString With Range(Cells(X, 1), Cells(X, "P")) .Interior.ColorIndex = 6 .Font.Bold = True .Font.Size = 14 End With Start_Row = Start_Row + k + 1 If Start_Row > lr Then GoTo 10 Next i 10 Application.ScreenUpdating = True totalsum_new With Range("A2:Q" & lr1 + 2) .Value = .Value .Borders.LineStyle = 1 End With End Sub Sub totalsum_new() LAST = [A9999].End(xlUp).Row + 2 Cells(LAST, "L") = "òALL SUM " Cells(LAST, "M").Resize(, 4).Formula = "=SUM(M3:M" & LAST - 1 & ")/ 2" Cells(LAST, "O") = vbNullString With Cells(LAST, "L").Resize(, 5) .Font.Bold = True .Font.Size = 14 .Interior.Color = 10092492 End With End Sub الملف مرفق صفحة" Taksim" Sum_Of-10.xlsm

يبدو ان اللغة العربية غير مثبتة عندك في برمجة الــVBA شاهد هذه الفيديو لحل المشكلة https://www.youtube.com/watch?v=hElkHVLg7a4

الأخ علي لا لزوم لهذه المعادلة الطويلة (لادراج من A الى Z ) تكفي هذه =IF(ROWS($A$1:A1)>26,"",CHAR(64+ROWS($A$1:A1))) ربما تنفع هذه الثلاث كودات Option Explicit Sub insert_arab() Dim i%, k% Dim arr() k = 0 Range("A1").CurrentRegion.ClearContents arr = Array(1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, _ 18, 19, 20, 21, 23, 24, 25, 27, 29, 30, 31, 32, 39) For i = LBound(arr) To UBound(arr) Range("A" & i + 1) = Chr(198 + arr(k)) k = k + 1 Next End Sub '++++++++++++++++++++++++++++++++++++ Sub insert_Cap() Range("C1").CurrentRegion.ClearContents Dim i% For i = 1 To 26 Range("C" & i) = Chr(64 + i) Next End Sub '++++++++++++++++++++++++++++++++++++++++++ Sub insert_Small() Range("F1").CurrentRegion.ClearContents Dim i% For i = 1 To 26 Range("F" & i) = Chr(96 + i) Next End Sub الملف مرفق ALPHABET.xlsm

كل شيء ممكن في الاكسيل 1-تغيير اسماء الصفحات ليتعرف عليها الاكسل بشكل جيد من جهة ومن جهة ثانية اسهل في كتابة الكود ونسخه ولصقه 2-التاريخ في الخلية B15 يجب ان يكتب كتاريخ وليس تاريخ ومعه الحرف م 3- الخلايا المدمجة في الصف الأول لا أنصح بها (لانها تسبب مشاكل في تحديد اخر صف فيه بيانات) 4- اذا كان التاريخ خطأ B15 تحصل على رسالة يذلك و يتوقف الكود عن العمل الكود Option Explicit Sub tansform_data() Dim B As Worksheet, Var_sh As Worksheet Dim Jour%, Mois%, Last_row% Dim Spec_rg As Range Set B = Sheets("By_jour") Set Spec_rg = B.Range("A15") If Not IsDate(Spec_rg) Then MsgBox "You Enter a wrong Date Please Justify" Exit Sub End If Jour = Day(Spec_rg): Mois = Month(Spec_rg) Select Case Mois Case 4 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("Ap1") Case Else Set Var_sh = Sheets("Ap2") End Select '+++++++++++++++++++++++++++++ Case 5 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("May1") Case Else Set Var_sh = Sheets("May2") End Select '+++++++++++++++++++++++++++++ Case 6 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("Jun1") Case Else Set Var_sh = Sheets("Jun2") End Select '+++++++++++++++++++++++++++++ Case 7 Select Case Jour Case Is <= 15 Set Var_sh = Sheets("Jul1") Case Else Set Var_sh = Sheets("Jul2") End Select Case Else Exit Sub End Select ' Var_sh.Select Last_row = Var_sh.Range("a:a").Find("", after:=Var_sh.Range("a3")).Row Var_sh.Cells(Last_row, 2).Resize(, 8).Value = _ B.Cells(12, 2).Resize(, 8).Value Var_sh.Cells(Last_row, 1) = Spec_rg End Sub الملف مرفق Tarhil_Youmi.xlsm

تم معالجة الامر MY_search (2).xlsx

Application.Sum(Sh.Cells(i, 1). _ Offset(, 4).Resize(, 5) في هذا السطر الرقم 5 في ((Resize(, 5) هو عدد الأعمدة التي تريد جمعها ابتداء من العامود الذي مسجل في (Offset(, 4 وتضيف عليه 1 (4+1)=5 (العامود E رقمه 5) مثلا اذا كنت تريد جمع عامود واحد تكتب (Resize(, 1 العامود فقط E اذا كنت تريد جمع عامودين تكتب (Resize(, 2 العامودين E و F

في الكود الحرف (ِA) يدل على العامود A اذا كنت تريد تغيير العامود استبدل A باسم آخر الذي تريده احياناً قد تجد حرف (a) لا مشكلة بذلك

بعد اذن اخي رائد ربما يكون هذا المطلوب (ادراج نفس رقم البطاقة لنقس المادة) Card_Number .xlsx

اسف يا صديقي قمت بتحميل ملف اخر بالخطأ الملف الصحيح 2020_new.xlsm

جرب هذا الكود (تم تغيير اسم الصفحة الرئيسية الى Salim) من اجل حسن نقل الكود ولصقه بعض الأعمدة مخفية من الصفحة لنتمكن من رؤية كامل الجدول (يمكنك اظهارها بسهولة) Option Explicit Sub salim_code() Rem Created By Salim Hasbaya On 15/4/2020 Rem you can change then Number 10 by _ any number in all The code by changing ""tt"" Const tt = 10 Dim S As Worksheet, sh As Worksheet Dim Ro%, i%, n%, m%, t%, x%, max_ro% Dim arr() Set S = Sheets("Salim") Ro = S.Cells(Rows.Count, 1).End(3).Row With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With '-------------- Delete all sheets Except the Main sheet Application.DisplayAlerts = False For Each sh In Sheets If sh.Name <> S.Name Then sh.Delete End If Next Application.DisplayAlerts = True '-------------------------------------- m = Ro \ tt n = (Ro Mod tt) m = IIf(n = 0, m, m + 1) ReDim arr(1 To m) arr(1) = 2: arr(2) = tt For x = 3 To m arr(x) = arr(x - 1) + tt Next For i = 1 To m S.Copy After:=Sheets(i) With ActiveSheet .Name = S.Name & i .Range("a1").CurrentRegion.Offset(1).Clear S.Range("A" & arr(i)).Resize(tt, 17).Copy .Cells(2, 1).PasteSpecial .Shapes.Range(Array("But_1")).Delete .Range("a1").Select End With Next i With Sheets("Salim" & m) max_ro = .Cells(Rows.Count, 1).End(3).Row If max_ro = 1 Then Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True ElseIf max_ro < tt + 1 Then .Range("A" & max_ro + 1).Resize(tt, 17).Clear End If End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False .DisplayAlerts = True End With S.Select: S.Range("a1").Select End Sub File Included Taksim_By_10.xlsm

Try This File AUTO_DATE.xlsx

لا ضرورة لرفع ملف من اكثر من 2000 صف يكفي نموذج بسيط (في الملف المرفق حوالي 130 صف )فقط لمعايتة الماكرو يمنكنك اضافة اي عدد من الصفوف في الورقة Toullab شرط عدم ترك خلايا فارغة في الصفوف حيث يعمل الفلتر ( الرابع السادس والسابع) شخصياً لا افضّل تسمية الشيتات باللغة الغربية لصعوبة كتابة الكود ونقله الكود Option Explicit Sub My_FILTER() Rem Created by Saliom Hasbaya on 14/4/2020 With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim T As Worksheet, S As Worksheet Dim T_Table As Range, mr As Range, era As Range Dim i%, lr%, x%, Homany%, k%, y% Dim arr Set T = Sheets("Toullab"): Set S = Sheets("Statics") arr = Array("الاول", "الثاني", "الثالث", "الرابع") Set T_Table = T.Range("A1").CurrentRegion If T.AutoFilterMode Then T_Table.AutoFilter lr = S.Cells(Rows.Count, 1).End(3).Row With S.Range("C4:D" & lr - 1) .ClearContents .Offset(, 3).ClearContents .Offset(, 6).ClearContents .Offset(, 9).ClearContents End With y = 2 For k = 0 To 3 For i = 4 To lr - 1 '++++++++++++++++++++++++++++++++++++ T_Table.AutoFilter 6, S.Cells(i, 1) T_Table.AutoFilter 7, arr(k) T_Table.AutoFilter 4, S.Cells(2, 3) Set mr = T_Table.SpecialCells(xlCellTypeVisible).Offset(1) For Each era In mr.Areas x = Application.CountA(era.Columns(7)) If x Then Homany = Homany + era.Rows.Count End If Next S.Cells(i, 1).Offset(, y) = Homany - 1: Homany = 0 '************************************************************ T_Table.AutoFilter 4, S.Cells(2, 4) Set mr = T_Table.SpecialCells(xlCellTypeVisible).Offset(1) For Each era In mr.Areas x = Application.CountA(era.Columns(7)) If x Then Homany = Homany + era.Rows.Count End If Next S.Cells(i, 1).Offset(, y + 1) = Homany - 1: Homany = 0 Next i y = y + 3 Next k If T.AutoFilterMode Then T_Table.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Set T = Nothing: Set S = Nothing Set T_Table = Nothing Set mr = Nothing: Set era = Nothing End Sub الملف مرفق OH_my_filter.xlsm

لا حاجة للكليندر بوجود القوائم المنسدلة (فقط عند نعديل او اضافة او حذف اي بيانات او تواريخ اضغط على الزر Get data validation) كي يعمل الكود جيداً بدون مشاكل لا يجب ان يكون خلايا فارغة في كل الجداول (العامود الاول ابتداء من الصف الخامس من كل ورقة ما عدا Salim)

اللون الاصفر يشير إلى التواريخ التي اخترتها (بين تاريخين) بالنسبة للكليندر يجب وضع 2 منها كل واحد برتبط بخلية (C2 & D2) او ادراج قوائم منسدلة في الخليتين هذا الكود يقوم بادراج قوائم منسدلة في الخليتين بدون تكرار التواريخ مرتبة تصاعدياً في القائمة الاولى وتنازلياً في الثانية Option Explicit Sub Get_data_val() Dim Main As Worksheet Dim Sh As Worksheet Dim CoL1 As Object Dim CoL2 As Object Dim i%, Last_Row%, m% Set Main = Sheets("Salim") Set CoL1 = CreateObject("System.Collections.Arraylist") For Each Sh In Sheets If Sh.Name <> Main.Name Then i = 5 Do Until Sh.Range("A" & i) = vbNullString With Sh.Range("A" & i) If IsDate(.Value) And Not CoL1.contains(.Value) Then CoL1.Add (.Value) End If End With i = i + 1 Loop End If Next Set CoL2 = CoL1.Clone CoL1.Sort: CoL2.Sort CoL1.Reverse With Main.Range("D2").Validation .Delete .Add 3, Formula1:=Join(CoL1.toarray, ",") End With With Main.Range("C2").Validation .Delete .Add 3, Formula1:=Join(CoL2.toarray, ",") End With Set Main = Nothing: Set Main = Nothing Set CoL1 = Nothing: Set CoL2 = Nothing End Sub Total_sum_With_DV.xlsm

تم النعديل على الماكرو كما تريد Option Explicit Sub Get_Sum_By_Array() Dim Main As Worksheet Dim Sh As Worksheet Dim Start_Date As Date, Final_date As Date Dim Last_Row%, i%, m%, AL_Result# Dim arr() Dim Tst$ Set Main = Sheets("Salim") Start_Date = Main.Cells(2, 3) Final_date = Main.Cells(2, 4) Tst = "الاجمالى" For Each Sh In Sheets If Sh.Name = Main.Name Or _ Sh.Name = "النقدية" Then GoTo Next_SH Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Range("A5:i" & Last_Row).Interior.ColorIndex = xlNone For i = 5 To Last_Row With Sh.Cells(i, 1) If .Value >= Start_Date And _ .Value <= Final_date And _ .Offset(, 1) <> Tst Then .Resize(, 9).Interior.ColorIndex = 6 ReDim Preserve arr(m) arr(m) = _ Application.Sum(Sh.Cells(i, 1). _ Offset(, 4).Resize(, 5)) m = m + 1 End If '.value End With Next i If m > 0 Then Sh.Cells(4, 2) = Application.Sum(arr) AL_Result = AL_Result + Application.Sum(arr) Else Sh.Cells(4, 2) = 0 AL_Result = AL_Result End If Erase arr: m = 0 Next_SH: Next Sh Main.Cells(2, 2) = AL_Result Set Main = Nothing: Set Sh = Nothing End Sub الملف مرفق Total__Super.xlsm

بعض التجسينات على الكود (لتحديد الصفوف المطلوبة للجمع حسب التواريخ) Option Explicit Sub Get_Sum_By_Array() Dim Main As Worksheet Dim Sh As Worksheet Dim Start_Date As Date, Final_date As Date Dim Last_Row%, i%, m%, AL_Result# Dim arr() Set Main = Sheets("Salim") Start_Date = Main.Cells(2, 3) Final_date = Main.Cells(2, 4) For Each Sh In Sheets If Sh.Name <> Main.Name Then Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Range("A5:I" & Last_Row).Interior.ColorIndex = xlNone For i = 5 To Last_Row If Sh.Cells(i, 1) >= Start_Date And _ Sh.Cells(i, 1) <= Final_date Then Sh.Cells(i, 1).Resize(, 9) _ .Interior.ColorIndex = 6 ReDim Preserve arr(m) arr(m) = _ Application.Sum(Sh.Cells(i, 1). _ Offset(, 4).Resize(, 5)) m = m + 1 End If Next i If m > 0 Then Sh.Cells(4, 2) = Application.Sum(arr) AL_Result = AL_Result + Application.Sum(arr) Else Sh.Cells(4, 2) = 0 AL_Result = AL_Result End If Erase arr: m = 0 End If Next Sh Main.Cells(2, 2) = AL_Result Set Main = Nothing: Set Sh = Nothing End Sub الملف من جديد Total_sum_Super.xlsm