سليم حاصبيا

قلت لك : حاول تطبيقه في ملف جديد فارغ انه المثال الذي طلبته (استدعاء كود من كود اخر) جربه و سترى عمله

هذا مثال حاول تطبيقه في ملف جديد فارغ Option Explicit Sub First_Code() Dim i Range("A1:B10").ClearContents For i = 1 To 10 Range("A" & i) = "First Code: " & i Next seconde_Code End Sub '++++++++++++++++++++++++++++ Sub seconde_Code() Dim k% For k = 1 To 10 Range("B" & k) = "Seconde Code:" & k Next End Sub

بمكن كتابة كود اخر ثم استدعاءه من الكود الأول

هذه العملية معقدة بعض الشيئ ولا مجال لشرحها كتا بة شاهد هذا الفيديو https://www.youtube.com/watch?v=F29G18GdTAQ&ab_channel=ExcelDestination

الكود يجذف اي تنسيق شرطي لذلك من اجل اضافة تنسيقات شرطية لا بد ان يكون ذلك من داخل الكود

تم معالجة الجرء الأول لكن الجزء الثاني فيه غموض (ربما بسبب الكتابة ياللغة العربية والأحنبية معاً بحيث لا تبدو المعطيات مفهومة) اضغط الزر User لاظهار اليوزر test RJS .xlsm

تفضل ما نريد Last_Jack_Black.xlsm

See This video https://www.youtube.com/watch?v=oTjUuFZNmy8&ab_channel=TubeMint

كيف تطلب التعديل وأنت لم تنزّل الملف حتى

تم معالجة الأمر لحذف جميع المعطيات التي في نفس السطر استبدل ما هو موجود في المربغ الأحمر من هذه الصورة بما هم موجود في المربع الأزرق (مع حذف الفاصلة العليا من أول السطر) الكود Option Explicit Sub Del_Empty_Many_rows() Dim my_rg As Range Dim Ro% With Sheets("Salim") Ro = .Cells(Rows.Count, "N").End(3).Row .Cells.FormatConditions.Delete Range("P9:P500").ClearContents On Error Resume Next Set my_rg = _ .Range("N9:N" & Ro).SpecialCells(4) my_rg.Delete xlUp 'my_rg.EntireRow.Delete On Error GoTo 0 Ro = .Cells(Rows.Count, "N").End(3).Row With .Range("P9").Resize(500) .Formula = "=IF(N9="""","""",MAX($P$8:P8)+1)" .Offset(, -15).Resize(, 43).FormatConditions _ .Add Type:=2, Formula1:="=$N9<>""""" .Offset(, -15).Resize(, 43).FormatConditions(1). _ Borders.LineStyle = 1 End With End With End Sub الملف مرفق Last_Jack.xlsm

كان من المفروض رفع ملف ولا تتكّل على أحد في انشاء ملف لك جرب هذا الشيء (فقط اضغط على الزر Run Please ) Numerical_names.xlsm

ارفع هذه الورقة في ملف مستقل و بدون تنسبق ألوان تبهر النطر و شاشة سوداء يتشائم منها الانسان و بدون اي كود

و من بفهم شيئاً في هكذا ملف؟؟؟؟

تم التعديل على الملف كما تريد (الدالة تعمل وكذلك التنسيق الشرطي) و عند الضغط على الزر يقوم الماكرو بازالة الصفوف (الاسماء) الغارغة و يحافظ على الدالة و التنسيق الشرطي Option Explicit Sub Del_Empty_1() Dim my_rg As Range Dim Ro% With Sheets("Salim") Ro = .Cells(Rows.Count, 2).End(3).Row .Cells.FormatConditions.Delete Range("A5:A500").ClearContents On Error Resume Next Set my_rg = _ .Range("B5:B" & Ro).SpecialCells(4) my_rg.Delete xlUp On Error GoTo 0 Ro = .Cells(Rows.Count, 2).End(3).Row With .Range("A5").Resize(500) .Formula = "=IF(B5="""","""",MAX($A$4:A4)+1)" .Resize(, 3).FormatConditions _ .Add Type:=2, Formula1:="=$B5<>""""" .Resize(, 3).FormatConditions(1). _ Borders.LineStyle = 1 End With End With End Sub الملف من جدبد jack305.+with_cond_formatxlsm.xlsm

هذا بدون زر Mhm_78_1.xlsm

يا صديقي لا لزوم للدالة طالما الكود يقوم بالترقيم التلقائي ثم عن اي تنسيق تتكلّم (ارفع صورة بالتنسيق الذي تريده)

تغيير اسماء الشيتات الى اللغة الأجنبية كما في كل مرة لحسن نسخ الكود واصقه Option Explicit Sub My_Report() With Sheets("Repport").Range("C4").Resize(12) .Value = _ Sheets("Sh_Plus").Range("C4").Resize(12).Value .Offset(, 1) = _ Sheets("Sh_Minus").Range("C4").Resize(12).Value .Offset(, 2).Formula = "=SUM(C4,-D4)" .Offset(, 2).Value = .Offset(, 2).Value End With End Sub الملف مرفق Mhmd78.xlsm

لم أذكر في الكود (ِAE) بل ذكرت رقم اخر عامود فيه بيانات (nCol) لأنه ربما لا يكون اخر غامود هو AE حسب كل صفخة

جرب هذا الكود Option Explicit Sub How_Many_A(My_Sh As Worksheet) Dim nCOL%, Nro$, x%, y% Nro = My_Sh.Cells(Rows.Count, 2).End(3).Row nCOL = My_Sh.Cells(1, Columns.Count).End(1).Column My_Sh.Cells(3, nCOL).Resize(Nro).ClearContents For x = 3 To Nro y = Application.CountIf(My_Sh.Cells(x, 3).Resize(, nCOL - 3), "A") My_Sh.Cells(x, nCOL) = IIf(y > 0, y, "") Next End Sub '++++++++++++++++++++++++++ Sub Sum_Of_A() Dim ws As Worksheet For Each ws In Sheets Call How_Many_A(ws) Next End Sub الملف مرفق (اضغط على الزر Run في الصفحة الأولى ويتم التنفيذ غلى كل الصفحات) Mohmad83.xlsm

تم التعديل على الملف ليعمل كما تريد Option Explicit Dim S As Worksheet Dim P As Worksheet Dim i%, k%, New_arr() Dim Rop%, Ros%, myEnd% Dim my_rg As Range, rgs As Range, RgP As Range Sub Salim_rand_table() If ActiveSheet.Name <> "Salim" Then GoTo End_Me Application.ScreenUpdating = False Set S = Sheets("Salim") Set P = Sheets("Page1_1") Set rgs = S.Range("B1").CurrentRegion Ros = rgs.Rows.Count If Ros > 1 Then rgs.Offset(1).Resize(Ros - 1).ClearContents End If myEnd = Application.CountA(P.Range("B:B")) - 1 Set my_rg = P.Cells(2, 2).Resize(myEnd) With CreateObject("System.Collections.SortedList") For i = 1 To myEnd .Item(Rnd) = i Next i ReDim New_arr(1 To .Count) For k = 1 To .Count New_arr(k) = Val(my_rg.Cells(.GetByIndex(k - 1))) Next End With With S.Range("B2").Resize(UBound(New_arr)) .Value = Application.Transpose(New_arr) .Value = .Value End With Please_Collction End_Me: Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++ Sub Please_Collction() Application.ScreenUpdating = False Dim x, y Set S = Sheets("Salim") Set rgs = S.Range("B1").CurrentRegion Ros = rgs.Rows.Count If Val(S.Range("L1")) <= 0 Then S.Range("L1") = 10 End If S.Range("C2").Resize(Ros).UnMerge S.Range("C2").Resize(Ros).Clear k = 1 For i = 2 To Ros Step Int(S.Range("L1")) Cells(i, 3) = "Equipe :" & k Cells(i, 3).Resize(Int(S.Range("L1"))).Merge k = k + 1 Next With S.Range("C2").Resize(Ros) .VerticalAlignment = 2 .HorizontalAlignment = 3 .Borders.LineStyle = 1 .Font.Size = 16 .Font.Bold = True End With Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++ الملف من جديد faicale_table_1.xlsm

هذا الكود يقوم بادراج جدول عشوائي في الشيت (Salim) للبيانات الموجودة في الشيت (Page1_1) Option Explicit Sub Salim_rand_table() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim S As Worksheet Dim P As Worksheet Dim i%, k%, New_arr() Dim Rop%, Ros%, myEnd% Dim my_rg As Range, Rgs As Range, RgP As Range Set S = Sheets("Salim") Set P = Sheets("Page1_1") Set Rgs = S.Range("B1").CurrentRegion Ros = Rgs.Rows.Count If Ros > 1 Then Rgs.Offset(1).Resize(Ros - 1).ClearContents End If myEnd = Application.CountA(P.Range("B:B")) - 1 Set my_rg = P.Cells(2, 2).Resize(myEnd) With CreateObject("System.Collections.SortedList") For i = 1 To myEnd .Item(Rnd) = i Next i ReDim New_arr(1 To .Count) For k = 1 To .Count New_arr(k) = Val(my_rg.Cells(.GetByIndex(k - 1))) Next End With With S.Range("B2").Resize(UBound(New_arr)) .Value = Application.Transpose(New_arr) .Value = .Value End With End Sub الملف مرفق ( فقط اضغط غلى الزر Tableau aléatoire) في الشيت (Salim) faicale_table.xlsm

لك ما تريد Ahmad82.xlsx

بعد اضافة الاسماء ( قدر ما تريد منها) أو حذف قدر ما تريد اضغط الزر Run على فكرة يوجد قاعدة للتنسيق الشرطي و لكن بدون ان تذكر ماذا تريد ان يظهر لك هذا التنسيق

قم بتفيير اسم الصقحة الى Salim لحسن نسخ الكود ولصقه بدون مشاكل اللغة العربية ونقذ هذا الكود Option Explicit Sub Del_Empty() Dim my_rg As Range Dim Ro% With Sheets("Salim") Ro = .Cells(Rows.Count, 2).End(3).Row .Range("A5").Resize(Ro - 4).ClearContents On Error Resume Next Set my_rg = _ .Range("B5:B" & Ro).SpecialCells(xlCellTypeBlanks) my_rg.Delete xlUp On Error GoTo 0 Ro = .Cells(Rows.Count, 2).End(3).Row .Range("A5").Resize(Ro - 4) = _ Evaluate("Row(1:" & Ro - 4 & ")") End With End Sub الملف مرفق jack305.xlsm

بعد اذن اخي محي الدين كان من المفروض رفع ملف لكن لأول مرة اليك هذا النموذج الكود Option Explicit Rem This Macro Insert chossen Number Of rows Every n Number Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range Application.ScreenUpdating = False If ActiveSheet.Name <> "Salim" Then GoTo End_Me If Val(Range("E2")) <= 0 _ Or Val(Range("F2")) <= 0 Then GoTo End_Me End If z = Int(Range("E2")) 'number of rows to be insert every time a = Int(Range("F2")) 'number of rows for every group Range("G2") = 4 x = 4 If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 lr = Cells(Rows.Count, 1).End(3).Row On Error Resume Next Set my_rg = Range("a" & x & ":a" & lr).SpecialCells(4) my_rg.EntireRow.Delete On Error GoTo 0 Do Until Cells(t, "A") = "" Rows(t).Resize(z).Insert t = t + z + a Loop End_Me: Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++ Sub del_Empty_rows() Dim ro%, Rg As Range ro = Cells(Rows.Count, 1).End(3).Row If ro < 4 Then Exit Sub Range("G2") = 4 On Error Resume Next Set Rg = Range("A4" & ":A" & ro).SpecialCells(4) Rg.EntireRow.Delete On Error GoTo 0 End Sub صورة توضح كيفية التعامل مع الملف الملف مرفق Insert_N_Rows.xlsm