سليم حاصبيا

جرب هذا الملف بعد اذن الاخ علي Split Text_salim.xlsm

جرب هذا الملف أوقات.xlsx

بارك الله فيك اخي علي و للمزيد أيصاُ هذا الملف ( انا أحببت من خلال الكود ان تطبق الطباعة كاملة ختى اخر صف مهما كان جحم الجدول) Sum Of N Rows.xlsx

جرب هذا الملف من ملفاتي القديمة Smart_Printing.xlsm

جرب هذا الماكرو Option Explicit Sub distribute_num() Application.ScreenUpdating = False With Sheets("sheet1") Dim cel As Range Dim my_rg As Range Set my_rg = .Range("e2:e" & .Cells(Rows.Count, "e").End(3).Row) For Each cel In my_rg If cel <> vbNullString Then 1: With cel .Offset(, -3) = Int(5 * (Rnd() + 1)) - 4 .Offset(, -2) = Int(10 * (Rnd() + 1)) - 9 .Offset(, -1) = cel - (cel.Offset(, -3) + cel.Offset(, -2)) If .Offset(, -1) > 10 Then GoTo 1 End If End With End If Next End With Application.ScreenUpdating = True End Sub الملف مرفق Rand_Number.xlsm

لك هذا الكود Option Explicit Sub find_abscent() Application.ScreenUpdating = False Dim Sh1 As Worksheet: Set Sh1 = Sheets("الشيت") Dim Sh2 As Worksheet: Set Sh2 = Sheets("abscent") Dim my_rg As Range: Set my_rg = Sh1.Range("c5").CurrentRegion Sh2.Range("TETE_RG").ClearContents Dim i%, k%: k = 1 Dim m%: m = 2 Dim arr(1 To 9) For i = 2 To 18 Step 2 arr(k) = Sh2.Cells(3, i) k = k + 1 Next k = 3 For i = LBound(arr) To UBound(arr) my_rg.AutoFilter k, "غ" k = k + 1 my_rg.Columns(1).SpecialCells(12).Copy _ Sh2.Cells(4, m) m = m + 1 my_rg.Columns(2).SpecialCells(12).Copy _ Sh2.Cells(4, m) m = m + 1 my_rg.AutoFilter Next Erase arr: Set my_rg = Nothing Application.ScreenUpdating = True End Sub الملف مرفق Abscet_Salim.xlsm

تم معالجة الامر في الملف المرفق working days_final _salim.xlsm اما بالنسبة للملف الثاني (الكود) يجب كنابة التاريخ بصيغة (شهر/يوم/سنة mm/dd/yyyy ) لانه كما يبدو الحهاز عندك بنظام اميركي او شاهد هذا الفيديو لمعرفة كيفية تغيير نظام التاريخ

ربما هذه المعادلة (Ctrl+Shift+Enter) =SUMPRODUCT((WEEKDAY(ROW(INDIRECT($L$9&":"&$M$9)))<6)*(WEEKDAY(ROW(INDIRECT($L$9&":"&$M$9)))<>3)) file include working days_final.xlsm انا لا افهم لماذا لا تريد استعمال هذا الملف في الاسفل wprking_days_Vba.xlsm

جرب هذا الكود تجد النتيجة قي الشيت 3 Option Explicit Sub transfer_data() Sheets("Sheet3").Cells.Clear Sheets("Sheet1").Range("A1").CurrentRegion.Copy Sheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True Application.CutCopyMode = False End Sub

هذا الملف يشرح كل شيئ بطيء بعض الشيء بسبب كثرة المعادلات (يجب الانتظار جوالى 25 ثانية لنتفيذ كل المعادلات) Tamdid And Count.xlsx

استاذي مصطفى المعادلة (قي العامود Y) يحب ان تمتد الى حوالي 2000 صف(عدد الايام في السنوات من 2016 الى 2020) اي $Y$2:$Y$2500 تقريباً و كذلك الى قي العامود ($V$2:$V$2500)

انظر جيداً بعد اخفاء بعض الصفوف و الترقيم working days Ex.xlsm

لم افهم ماذا تقصد بــ( ما عدا الفرق بين تارخين ( أيام العمل )) بالنسبة للتمديد اضف الى المعادلة (قي العامود Y) الرقم الذي تريده مكان الرقم 4 (تمديد اربع سنوات) =IF(YEAR(DATE($Z$2,1,ROWS($Y$1:Y1)))>$Z$2+4,"",DATE($Z$2,1,ROWS($Y$1:Y1)))

جرب هذا الماكرو Option Explicit Sub tarnsfer_daya() Dim Rg1 As Range: Set Rg1 = DATA.Range("a5").CurrentRegion Dim last_ro%: last_ro = Rg1.Rows.Count Dim last_col%: last_col = Rg1.Columns.Count Dim lr%: lr = ABSCENT.Cells(Rows.Count, 1).End(3).Row ABSCENT.Range("B7:S" & lr).ClearContents Dim i%, K%, St$, mtch% Dim m%: m = 7 For i = 7 To last_ro + 4 For K = 4 To last_col - 7 If DATA.Cells(i, K) = "غ" Then St = DATA.Cells(5, K) On Error Resume Next mtch = Application.Match(St, ABSCENT.Rows(5), 0) If Err.Number <> 0 Then On Error GoTo 0 GoTo 1 End If ABSCENT.Cells(m, mtch) = DATA.Cells(i, "B") ABSCENT.Cells(m, mtch + 1) = DATA.Cells(i, "C") End If 1: Next m = m + 1 Next End Sub الملف مرفق Salim_Abscent.xlsm

جرب هذا الشيء working days.xlsm

الكود يقوم بترحيل البيانات التي تحتوي على معلومات من البيانات المحاطة بالإطار الملون (يتحاشى الاصفار) في المثال الذي ارسلته سطرين من كل مجموعة جرب كتابة اكثر من سطرين و سترى النتيجة

جرب هذا الماكرو Option Explicit Sub Tarhil_Data() Dim my_rg_1 As Range Dim my_rg_2 As Range Dim my_rg_1_part_1 As Range Dim my_rg_2_part_1 As Range Dim My_Num: My_Num = Sheets("REZ").[c6] If Not IsError(Application.Match(My_Num, Sheets("DATA") _ .Range("B:B"), 0)) Or My_Num = vbNullString Then MsgBox "the Res.Number is allready Exist" & Chr(10) & "Or" _ & Chr(10) & " Res.Number is Empty " & _ Chr(10) & Chr(10) & "I can't transfere the Data", 64 Exit Sub End If Dim x1%, x2%, lr% lr = Sheets("DATA").Cells(Rows.Count, "D").End(3).Row + 1 x1 = Application.Match(0, Sheets("REZ").Range("H14:H18"), 0) x2 = Application.Match(0, Sheets("REZ").Range("H22:H26"), 0) With Sheets("REZ") Set my_rg_1 = .Range("B14:I" & x1 + 12) Set my_rg_2 = .Range("B22:I" & x2 + 20) Set my_rg_1_part_1 = .Range("B14:G" & x1 + 12) Set my_rg_2_part_1 = .Range("B22:G" & x2 + 20) End With With Sheets("DATA") .Range("B" & lr) = Sheets("REZ").Range("c6") .Range("C" & lr) = Sheets("REZ").Range("c7") .Range("D" & lr).Resize(my_rg_1.Rows.Count, 8).Value = my_rg_1.Value End With lr = lr + my_rg_1.Rows.Count Sheets("DATA").Range("D" & lr).Resize(my_rg_2.Rows.Count, 8).Value = my_rg_2.Value my_rg_1_part_1.ClearContents: my_rg_2_part_1.ClearContents Sheets("REZ").[c6:c7].ClearContents Set my_rg_1 = Nothing: Set my_rg_2 = Nothing Set my_rg_1_part_1 = Nothing Set my_rg_2_part_1 = Nothing End Sub الملف مرفق My_TARHIL.xlsm

تم تفعيل الجدول لغاية المرتبة 1000 ترتيب الطلاب _Up_100.xlsm

تم معالجة الامر الكود Option Explicit Sub resume_facture() Dim my_arr2(1 To 2) my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ": Dim i%, k%, m%: m = 2 Dim s# Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row Dim laste_e% Dim laste_B% Detail.Range("A1:e" & lr2).ClearContents By_Date.Range("a1:b" & lr3).ClearContents Dim Fter_Rg As Range Set Fter_Rg = Achat.Range("a1:e" & lr1) Dim Col As Object Set Col = CreateObject("system.collections.arraylist") With Col For i = 2 To lr1 If Not .contains(Achat.Range("b" & i).Value) Then _ .Add Achat.Range("b" & i).Value Next End With For i = 0 To Col.Count - 1 '----------------------------- laste_e = Detail.Cells(Rows.Count, 1).End(3).Row If laste_e% <> 1 Then laste_e% = laste_e% + 2 '========================= Fter_Rg.AutoFilter 2, Col.Item(i) Fter_Rg.SpecialCells(12).Copy _ Detail.Range("a" & laste_e%) Next Fter_Rg.AutoFilter Col.Clear '========================= By_Date.Cells(1, 1).Resize(, 2) = my_arr2 For i = 2 To lr1 If Not Col.contains(Achat.Range("d" & i).Value) Then _ Col.Add Achat.Range("d" & i).Value Next '========================= For i = 0 To Col.Count - 1 By_Date.Range("b" & i + 2) = Col.Item(i) For k = 2 To Fter_Rg.Rows.Count If Achat.Range("D" & k) = Col.Item(i) Then s = s + Achat.Range("C" & k) End If Next By_Date.Range("A" & i + 2) = s s = 0 Next Creat_formula '=================== End Sub Rem+++++++++++++++++++++++++++++++++++++++++++++++++ Sub Creat_formula() With Detail Dim arr1(), arr2(), k%: k = 1 Dim t%: t = 1 Dim i% Dim Ro%: Ro = .Cells(Rows.Count, 2).End(3).Row For i = 2 To Ro + 1 If .Cells(i, 2) = "" Then .Cells(i, 1) = "Sum" End If Next .Range("F2:F" & Ro).Formula = "=IF(NOT(ISNUMBER(C2)),"""",SUM(C2,-E2))" '========================== For i = 1 To Ro + 1 If .Cells(i, 1) = "رقم بطاقة السكن" Then ReDim Preserve arr1(1 To k): arr1(k) = (.Cells(i, 1).Row) + 1 k = k + 1 End If Next For i = 1 To Ro + 1 If .Cells(i, 1) = "Sum" Then ReDim Preserve arr2(1 To t): arr2(t) = (.Cells(i, 1).Row) - 1 t = t + 1 End If Next '========================= For i = LBound(arr1) To UBound(arr1) With .Cells(arr2(i) + 1, 3) .Formula = "=SUM(C" & arr1(i) & ":C" & arr2(i) & ")" .Offset(, 2).Formula = "=SUM(E" & arr1(i) & ":E" & arr2(i) & ")" .Offset(, 3).Formula = "=SUM(F" & arr1(i) & ":F" & arr2(i) & ")" End With Next Erase arr1: Erase arr2 End With End Sub _Version _1 _salim.xlsm

نوجد دالة مغرفة للعدد حتى رقم 1000 اليك الكود لهذا الامر Option Explicit Function Order_Salim(cel) Dim degree$, i%, My_num1%, My_num2% Dim aHad$, Asharat$ If Not IsNumeric(cel) Then Order_Salim = "N/A": Exit Function If cel = 100 Then Order_Salim = "المائة": Exit Function End If If cel > 100 Then Order_Salim = "too Big Number": Exit Function End If cel = Int(Abs(cel)) Dim deg1$, deg2$, deg3$, deg4$, deg5$, deg6$, deg7$, deg8$, deg9$, deg10$ deg1 = "الأوّل": deg2 = "الثّاني": deg3 = "الثّالث": deg4 = "الرّابع" deg5 = "الخامس": deg6 = "السّادس": deg7 = "السّابع": deg8 = "الثّامن": deg9 = "التّاسع": deg10 = "العاشر" Dim deg01$, deg02$, deg03$, deg04$, deg05$, deg06$, deg07$, deg08$, deg09$ deg01 = "عشر": deg02 = "والعشرون": deg03 = "والثّلاثون": deg04 = "والأربعون": deg05 = "والخمسون" deg06 = "والستون": deg07 = "والسّبعون": deg08 = "والثّمانون": deg09 = "والتّسعون" If cel < 11 Then Select Case cel Case Is = 1: degree = deg1 Case Is = 2: degree = deg2 Case Is = 3: degree = deg3 Case Is = 4: degree = deg4 Case Is = 5: degree = deg5 Case Is = 6: degree = deg6 Case Is = 7: degree = deg7 Case Is = 8: degree = deg8 Case Is = 9: degree = deg9 Case Is = 10: degree = deg10 End Select Order_Salim = degree: Exit Function Else My_num1 = Mid(cel, 2, 1) '=========================== Select Case My_num1 '======================= Case Is = 1: aHad = "الحادي" Case Is = 2: aHad = deg2 Case Is = 3: aHad = deg3 Case Is = 4: aHad = deg4 Case Is = 5: aHad = deg5 Case Is = 6: aHad = deg6 Case Is = 7: aHad = deg7 Case Is = 8: aHad = deg8 Case Is = 9: aHad = deg9 End Select '====================== My_num2 = Mid(cel, 1, 1) Select Case My_num2 Case Is = 1: Asharat = deg01 Case Is = 2: Asharat = deg02 Case Is = 3: Asharat = deg03 Case Is = 4: Asharat = deg04 Case Is = 5: Asharat = deg05 Case Is = 6: Asharat = deg06 Case Is = 7: Asharat = deg07 Case Is = 8: Asharat = deg08 Case Is = 9: Asharat = deg09 End Select If My_num1 = 0 Then Order_Salim = Right(aHad & " " & Asharat, Len(aHad & " " & Asharat) - 2) Else Order_Salim = aHad & " " & Asharat End If End If End Function '=========================================================== Function OrdeUP100(cel) If Not IsNumeric(cel) Or Int(cel) <> cel Or Int(cel) <= 0 Then OrdeUP100 = "ERROR": Exit Function End If If cel = 1000 Then OrdeUP100 = "الألف": Exit Function If cel > 1000 Then OrdeUP100 = "Too Large Integer": Exit Function Dim x, y Dim Mi3at, Free, Martab1 If cel <= 99 Then OrdeUP100 = Order_Salim(cel): Exit Function Select Case Left(cel, 1) Case Is = 1: Mi3at = "مئة" Case Is = 2: Mi3at = "مئتين" Case Is = 3: Mi3at = "ثلاثمائة" Case Is = 4: Mi3at = "أربعمئة" Case Is = 5: Mi3at = "خمسمئة" Case Is = 6: Mi3at = "ستمئة" Case Is = 7: Mi3at = "سبعمئة" Case Is = 8: Mi3at = "ثمانمئة" Case Is = 9: Mi3at = "تسعمئة" End Select If Mid(cel, 2, 1) = 0 Then Free = Right(cel, 1) Select Case Free Case 0: Martab1 = "" Case 1: Martab1 = " وواحد" Case 2: Martab1 = "وإثنين" Case 3: Martab1 = "وثلاثة" Case 4: Martab1 = "وأربعة" Case 5: Martab1 = "وخمسة" Case 6: Martab1 = "وستة" Case 7: Martab1 = "وسبعة" Case 8: Martab1 = "وثمانية" Case 9: Martab1 = "وتسعة" End Select OrdeUP100 = Mi3at & " " & Martab1: Exit Function End If OrdeUP100 = Mi3at & " و" & Order_Salim(Mid(cel, 2, 2) * 1) End Function استعمال الدالة ( العدد ) Function OrdeUP100 الملف مرفق order_up_to_100.xlsm

جرب هذا الماكرو Option Explicit Sub resume_facture() Dim my_arr2(1 To 2) my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ": Dim i%, k%, m%: m = 2 Dim s# Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row Dim laste_D% Dim laste_B% Detail.Range("A1:D" & lr2).ClearContents By_Date.Range("a1:b" & lr3).ClearContents Dim Fter_Rg As Range Set Fter_Rg = Achat.Range("a1:d" & lr1) Dim Col As Object Set Col = CreateObject("system.collections.arraylist") With Col For i = 2 To lr1 If Not .contains(Achat.Range("b" & i).Value) Then _ .Add Achat.Range("b" & i).Value Next End With For i = 0 To Col.Count - 1 '----------------------------- laste_D = Detail.Cells(Rows.Count, 1).End(3).Row If laste_D% <> 1 Then laste_D% = laste_D% + 2 '========================= Fter_Rg.AutoFilter 2, Col.Item(i) Fter_Rg.SpecialCells(12).Copy _ Detail.Range("a" & laste_D%) Next Fter_Rg.AutoFilter Col.Clear '========================= By_Date.Cells(1, 1).Resize(, 2) = my_arr2 For i = 2 To lr1 If Not Col.contains(Achat.Range("d" & i).Value) Then _ Col.Add Achat.Range("d" & i).Value Next '========================= For i = 0 To Col.Count - 1 For k = 2 To Fter_Rg.Rows.Count If Achat.Range("D" & k) = Col.Item(i) Then By_Date.Range("b" & i + 2) = Col.Item(i) s = s + Achat.Range("C" & k) End If Next By_Date.Range("A" & i + 2) = s s = 0 Next '=================== End Sub الملف مرفق _salimجدول الشراء.xlsm

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

ممكن ان يتساوى اكبر أو أصغر معدل (بين طالبين أو أكثر) لذلك كان هذا التصحيح في الملف example_salim.xlsx

تم التعديل ترتيب الطلاب _salim (3).xlsm

تم التعديل على الملف كما تريد تم ايضاً جماية المعادلات لعدم العبث بها عن طريق الخطأ ترتيب الطلاب _salim (2).xlsm