نجوم المشاركات

السلام عليكم ورحمة الله وبركاته النسخة تجريبية وبدون أكواد برامج المواقيت كثيرة وأكثر احترافية وفي كل جوال ولكن بين فترة وأخرى أحب أن أتحدى الأكسل وفي كل مرة يكسب التحدي ويبدى امكانياته الهائلة مواقيت الصلاة.xlsb

ادارة المجموعات كلمة السر الحمد لله ادارة سنتر للدروس.xlsm

نعم صحيح 1= لا يوجد تكرار وهذا تعديل للمعادلة لزيادة التأكد تم إضافة TRIM لحذف الفراغات =SUMPRODUCT(((TRIM(RIGHT($A1:$A$1;6)))=TRIM((RIGHT(A1;6))))*1)

فوزى فوزى luxorman احمد عبدالحليم شكرا لدعواتكم وفقكم الله

يمكنك وضع هذه المعادلة في الخلية B4 =DATE(MID(LEFT(RIGHT(I4,12),8),1,4),MID(LEFT(RIGHT(I4,12),8),5,2),MID(LEFT(RIGHT(I4,12),8),7,2)) والاستغناء عن الأعمدة المساعدة بالتوفيق

حسب فهمي للمطلوب يلزمك تغيير المعادلة في الخلية E2 إلى =SUMIFS(الصرف!$C$2:$C$8,الصرف!$B$2:$B$8,$A$1,الصرف!$A$2:$A$8,">="&D2,الصرف!$A$2:$A$8,"<="&EOMONTH(D2,0),الصرف!$C$2:$C$8,">="&0)*$L$1+SUMIFS(الصرف!$C$2:$C$8,الصرف!$B$2:$B$8,$A$1,الصرف!$A$2:$A$8,">="&D2,الصرف!$A$2:$A$8,"<="&EOMONTH(D2,0),الصرف!$C$2:$C$8,"<"&0) رغم اعتراضي على اختلاف طريقة تسجيل البيانات فإذا كان العدد 3 يتم ضربه في 1000 لذلك يجب كتابة ال 500 على صورة 0.5 فهذا سيقلل المعادلة ويضبط المخرجات بالتوفيق

تعديل ممتاز تسلم ايديك هو المطلوب ربنا يجزيكم خير ويبارك فيكم وفى والديكم

وعليكم السلام ورحمة الله تعالى وبركاته استاذي الكريم @ابو جودي هل هو المطلوب ؟ Get Value Combo Box Multi Select.accdb

تفضل اخى لعل هذا المطلوب نرحيل.xlsm

بارك الله لك وجعله فى ميزان حسناتك عمل اكثر من رائع وتصميم اكثر من رائع

مميز بجد بارك الله فيك وجعله الله في ميزان حسناتك

عمل رائع وممتاز وحتى يكتمل العمل يكون الملف غير محمى واظهار الشيتات المخفيه وادامكم الله فى طاعته

كل الشكر والامتنان لك اخي @شايب والشكر موصول لجميع اساتذتنا ومعلمينا في المنتدى والشكر موصول ايضاً @متقاعد فعلا الكود السابق مأخوذ من مشاركتكم السابقة استفدت منه وبقي ما تفضلتم بالاجابة عليه ... اكرر شكري وامتناني ...اسئل الله ان ينفعنا بعلمكم ويزيدكم من فضله وكرمة

شكرا أساتذتي لمروركم الجميل ودعمكم المستمر

وعليكم السلام ورحمة الله وبركاته بارك الله فيكم وجعله الله في ميزان حسناتكم أحسنتم أخي الكريم @أبوأحـمـد أحسن الله إليكم جزاكم الله خيراً.

وعليكم السلام اخونا العزيز شايب يجزم ان هذا الكود من عملنا الاخ متقاعد وعلى الرغم من عدم الاقتناع بعمل متقاعد الا انه يمكن تنفيذ ماتريد باضافة السطر التالي rs!feah = fld.Properties("Caption") بعد rs.AddNew الملف مرفق مع عدم الاقتناع اخونا الشايب test2023(1).accdb

وعليكم السلام يمكن أيضا عمل الفكرة بالكود أمر طباعة وزيادة العدد ويمكن إضافة عبارات مع الرقم تفضل أرقام.xlsx

ما شاء الله جعله الله في ميزان حسناتك

بارك الله فيك وجعله الله في ميزان حسناتك

أحسنت استاذنا الكريم عمل ممتاز جعله الله فى ميزان حسناتك وبارك الله فيك

بارك الله فيك أخي الكريم وفقكم الله

وعليكم السلام ورحمة الله وبركاته بارك الله فيك وجعله الله في ميزان حسناتك

اخى بنسخ الكود مره اخرى به تعديل بسيط ليتفادى مشكله عدم وجود شيت باسم reservation

الأكواد توضع في محرر الأكواد اضغط ALT + F11 للدخول لمحرر الأكواد من قائمة Insert أدرج موديول جديد Module قم بنسخ الكود من المشاركة السابقة ثم لصقه في الموديول ارجع لورقة الإكسيل واضغط ALT + F8 سيظهر لك مربع حواري فيه اسم الماكرو أو الكود Test انقر على الأمر Run ستظهر النتائج في العمود الرابع

تم تعديل المعادلات مقتبسة من أستاذنا الفاضل / ياسر خليل أبو البراء خبير أوفسينا OK OK للرفع.xlsx

وعليكم السلام جرب الكود التالي حيث سيقوم الكود باستخراج القيم الفريدة أي الغير مكررة ويضعها في العمود الرابع Sub Test() Dim d As Object, rng As Range, c As Range Set d = CreateObject("Scripting.Dictionary") Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) For Each c In rng If c.Value <> "" Then d(Val(c.Value)) = Empty Next c Range("D1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys) End Sub

تفضل يابو محمد اذا احتجت مخرجات اخرى يمكنك عرض طلبك هنا ولن يألوا جهدا اخوانك هنا من الخبراء والاعضاء في مساعدتك ملحوظة : للدخول على التصميم اضغط على مفتاح الشيفت متزامنا مع فتح البرنامج DataFarm.rar

بعد اذن الاخ أبوأحـمـد جرب هذا الكود سيقوم بالتحقق من وجود القيم المكررة في الأعمدة A و B و C وسيقوم بسحب القيم المكررة إلى الأسفل Private Sub RemoveDuplicatesAndFillDown() Dim ws As Worksheet Dim lastRow As Long Dim colRangeA As Range Dim colRangeB As Range Dim colRangeC As Range Dim cell As Range ' تعيين الورقة المستهدفة Set ws = ThisWorkbook.Worksheets("التكويد") ' العثور على آخر صف غير فارغ في العمود C lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ' تعيين نطاقات الأعمدة A و B و C Set colRangeA = ws.Range("A2:A" & lastRow) Set colRangeB = ws.Range("B2:B" & lastRow) Set colRangeC = ws.Range("C2:C" & lastRow) ' إلغاء تنسيق الخلايا المحددة colRangeA.NumberFormat = "General" colRangeB.NumberFormat = "General" colRangeC.NumberFormat = "General" ' إزالة القيم المكررة وسحب القيم إلى الأسفل في الأعمدة A و B For Each cell In colRangeA If Application.WorksheetFunction.CountIf(colRangeA, cell.Value) > 1 Then cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value End If Next cell For Each cell In colRangeB If Application.WorksheetFunction.CountIf(colRangeB, cell.Value) > 1 Then cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value End If Next cell For Each cell In colRangeC If Application.WorksheetFunction.CountIf(colRangeC, cell.Value) > 1 Then cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value End If Next cell End Sub

وعليكم السلام 🙂 اخي الفاضل ، الكود عندك صحيح وما فيه اي مشكلة 😁 بس رجاء الانتباه الى ان نموذجك معمول لإدخال البيانات ، وليس لمعاينة البيانات السابقة : وانت لا ترى نتائج الكود ، لأن السجل ينتقل الى السجل التالي ، لهذا اعمل التغيير التالي في اعدادات نموذجك ، حتى ترى رقم السجل الذي انت عليه : .

Option Explicit '====================================================== ' اول صف للتقرير Private Const iRow As Integer = 8 '------------------------------------------------------ ' اسم ورقة التقارير Private Const Sh_Report As String = "التقرير" '------------------------------------------------------ ' اسم ورقة البيانات Private Const Sh_MyDate As String = "data" '------------------------------------------------------ ' تعيين نطاق الخلايا في ورقة البيانات ' ويشمل رؤوس الاعمدة Private Const MyRng_MyDate As String = "A2:z1000" '====================================================== Private MyRng As Range Private Num As Integer Private Const Mycount As Integer = 10 Private Sub CommandButton1_Click() Dim R As Integer Application.ScreenUpdating = False For R = 1 To Num If Me.Controls("CheckBox" & R).Value = True Then Kh_Start R End If Next Kh_PageSetup Application.GoTo Range("A1"), True Application.ScreenUpdating = True Unload Me End Sub Private Sub Kh_Start(iColumn As Integer) Dim RCount As Long, C As Integer C = Cells(iRow, Columns.Count).End(xlToLeft).Column + 1 With MyRng RCount = .Cells(.Rows.Count, 1).End(xlUp).Row .Cells(1, iColumn).Resize(RCount, 1).Copy ' لصق عرض الاعمدة Cells(iRow, C).PasteSpecial xlPasteColumnWidths ' لصق الفورمات Cells(iRow, C).PasteSpecial xlPasteFormats ' لصق القيم Cells(iRow, C).PasteSpecial xlPasteValues Application.CutCopyMode = False End With End Sub Private Sub UserForm_Initialize() Dim MyTop As Integer, i As Integer Dim MyCBox As Control '======================== kh_MyRngSet '======================== MyTop = 0 For i = 1 To Num Set MyCBox = Frame1.Controls.Add("Forms.CheckBox.1") With MyCBox .Move 12, MyTop, , , True .Alignment = 0 .Font.Bold = True .Caption = MyRng.Cells(1, i).Value .Value = True .TextAlign = fmTextAlignRight End With MyTop = MyTop + 24 Next '======================== With Me If Num <= Mycount Then .Height = 60 + (24 * Num) .Frame1.Height = (24 * Num) Else .Height = 60 + (24 * Mycount) .Frame1.Height = (24 * Mycount) .Frame1.ScrollBars = 2 .Frame1.ScrollHeight = (Num) * 24 End If End With '======================== End Sub Private Sub kh_MyRngSet() With Sheets(Sh_Report) .Select .Range(Cells(iRow, 2), Cells(.Rows.Count, .Columns.Count)).Clear .PageSetup.PrintArea = "" End With With Sheets(Sh_MyDate) Set MyRng = .Range(MyRng_MyDate) End With Num = MyRng.Columns.Count End Sub Private Sub Kh_PageSetup() Dim Lastrow As Long Dim LastColumn As Integer With Sheets(Sh_Report) Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row LastColumn = .Cells(iRow, Columns.Count).End(xlToLeft).Column With .PageSetup .PrintArea = Range("B2", Cells(Lastrow, LastColumn)).Address .zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With End With End Sub Private Sub UserForm_Terminate() Set MyRng = Nothing End Sub البرنامج كنز يحتوي على مجموعه من الاكواد ولا أروع هذا الكود للعلامه عبد الله باقشير

Sub Sheets_Arrays1() Dim temp As Variant Dim arr As Variant Dim F As Boolean Dim ws As Variant Dim WSdata As Worksheet: Set WSdata = Sheets("Total") For Each ws In Sheets(Array("1", "2", "3")) temp = ws.Range("k5:N" & ws.Cells(Rows.Count, 11).End(xlUp).Row).Value If F Then arr = ArrayJoin(arr, temp) Else arr = temp F = True End If Next ws With Sheets("Total") .Range("C4").Resize(1, 4).Value = Array("م", "الاسم", "الرقم الوظيفي", "سعد") .Range("C5").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End With End Sub '''''''''''''''''''ترحيل البيانات في اخر صف فارغ''''''''''''''''''''''' Sub Sheets_Arrays2() Dim F&, j& Dim ws As Variant Dim WSdata As Worksheet: Set WSdata = Sheets("Total") WSdata.Range("C4").Resize(1, 4).Value = Array("م", "الاسم", "الرقم الوظيفي", "سعد") For Each ws In Sheets(Array("1", "2", "3")) F = ws.Cells(Rows.Count, "K").End(xlUp).Row j = WSdata.Cells(Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False ws.Range("K5:N" & F).Copy Destination:=WSdata.Range("C" & j + 1) Application.ScreenUpdating = True Next ws End Sub ترحيل من عدة صفحات V3.xlsm

تفضل اخى الكريم ترحيل الغياب.xlsm

ما شاء الله أخي حسونه أنت رائع ...رحم الله والديك ...وجزاك الله خيرا أخي الحبيب فضلا انظر في هذا ...توجد مشكلة يسيرة يسر الله أمورك وجربت وضع 500 طالب ولم يعمل الكود ...والمعذرة على ازعاجكم نفع الله بكم. ترحيل الغياب - Copy.xlsm

السلام عليكم ورحمة الله حاول تطبيق الماكرو في هذا الملف على الملف لديك حسين.xlsm

الملف من جديد مع اختيار التاريخ من الى في الحلايا L2 و M2 في حال الخطأ بكتابة التواريخ في L2 او M2 او ادراح تواريخ غير موجودة في البيانات يقوم الماكرو بادراج كل التواريخ من اصغرها الى اكبرها اذا كنت تريد يوما واجداً اجعل L2 و M2 متساويتين (مثلا لاختيار 10 ابريل اكتب 10/4/2021 في L2 و M2) Option Explicit Sub All_In_One() Dim SH(), itm, My_sh As Worksheet Dim T As Worksheet Dim Sb#, Sc#, Sd#, Se#, Sf#, Sg# Dim ads%, k%, n%, Ro%, Max_row% Dim X As Date Dim Dat1 As Date, Dat2 As Date Dim F_rg As Range, Wat Set T = Sheets("Total") Max_row = Sheets("Reg1").Cells(Rows.Count, 1).End(3).Row If Not IsDate(T.Range("L2")) Or _ IsError(Application.Match(T.Range("L2"), _ Sheets("Reg1").Range("A3:A" & Max_row), 0)) Or _ IsError(Application.Match(T.Range("M2"), _ Sheets("Reg1").Range("A3:A" & Max_row), 0)) Then Dat1 = Application.Min(Sheets("Reg1").Range("A3:A" & Max_row)) Dat2 = Application.Max(Sheets("Reg1").Range("A3:A" & Max_row)) T.Range("L2") = Dat1: T.Range("M2") = Dat2 Else Dat1 = Application.Min(T.Range("L2"), T.Range("M2")) Dat2 = Application.Max(T.Range("L2"), T.Range("M2")) T.Range("L2") = Dat1: T.Range("M2") = Dat2 End If k = T.Cells(Rows.Count, 1).End(3).Row If k < 3 Then Exit Sub T.Range("A3").Resize(k - 2, 7).ClearContents SH = Array("Reg1", "Reg2", "Reg3", "Reg4", "Reg5") For X = Dat1 To Dat2 T.Range("A3").Offset(n) = Dat1 + n n = n + 1 Next k = T.Cells(Rows.Count, 1).End(3).Row For n = 3 To k Wat = T.Range("A" & n) For Each itm In SH Set My_sh = Sheets(itm) Ro = My_sh.Cells(Rows.Count, 1).End(3).Row If Ro < 3 Then GoTo Next_Itm Set F_rg = My_sh.Range("A2:A" & Ro).Find(Wat, Lookat:=1) If F_rg Is Nothing Then GoTo Next_Itm ads = F_rg.Row Sb = Sb + Val(My_sh.Cells(ads, "B")) Sc = Sc + Val(My_sh.Cells(ads, "C")) Sd = Sd + Val(My_sh.Cells(ads, "D")) Se = Se + Val(My_sh.Cells(ads, "E")) Sf = Sf + Val(My_sh.Cells(ads, "F")) Sg = Sg + Val(My_sh.Cells(ads, "G")) Next_Itm: Next itm With T.Cells(n, 2) .Value = Sb: Sb = 0 .Offset(, 1) = Sc: Sc = 0 .Offset(, 2) = Sd: Sd = 0 .Offset(, 3) = Se: Se = 0 .Offset(, 4) = Sf: Sf = 0 .Offset(, 5) = Sg: Sg = 0 End With Next n End Sub الملف من جديد Hasan_Choise.xlsm

أخى الفاضل جرب هذه الطريقة لحذف كود معين داخل موديول Const Mod_Num = "Module2" Const Cod_Nam = "Test" Sub ragab() With ThisWorkbook.VBProject.VBComponents(Mod_Num).CodeModule .DeleteLines .ProcStartLine(Cod_Nam, 0), .ProcCountLines(Cod_Nam, 0) End With End Sub فى السطر الأول تحدد اسم الموديول الذى يحتوى على الكود Const Mod_Num = "Module2" فى السطر الثانى تحدد اسم الكود المراد حذفه Const Cod_Nam = "Test" وسوف تجد فى الملف المرفق مثال لذلك ملحوظة : لكى يعمل الكود بشكل سليم قم بعمل الأتى من محرر الأكواد اختار References من قائمة tools ثم ضع علامة صح أمام الإختيار Microsoft Visual Basic For Applications Extensibility حذف كود فقط.rar