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

استخدمنا هذه الفانكشن Function masdatediffh(olddate, Optional newdate) As String Dim d As Integer, m As Integer, y As Integer, nd As Integer, nm As Integer, ny As Integer If IsNull(newdate) Then newdate = Date If IsNull(olddate) Or olddate > newdate Then masdatediffh = "": Exit Function nd = Left(newdate, 2): d = Left(olddate, 2) nm = Mid(newdate, 4, 2): m = Mid(olddate, 4, 2) ny = Right(newdate, 4): y = Right(olddate, 4) If nd < d Then nm = nm - 1: nd = nd + 30 If nm < m Then ny = ny - 1: nm = nm + 12 masdatediffh = Format(nd - d, "00") & "-" & Format(nm - m, "00") & "-" & Format(ny - y, "00") End Function الفانكشن بيعطينا عدد سنوات و الاشهر والايام بين تاريخين تغيرنا مصدر النموذج من الجدول الى استعلام واضفنا حقل جديد باسم Feriq هكذا Feriq: masdatediffh([تاريخ التعيين];Date()) لان حضرتك تريد سنة في مربع و اشهر في المربع و اليوم في المربع قمنا باخفاء المربع نصي اللي اسمه Feriq في النموذج وفي مربع الثلاث للسنة والاشهر والايام استخدمنا دالة Mid لان فانکشن يعطينا النتيجة رقمين للايام و شارحة ورقمين للاشهر و شارحة ورقمين للسنة هكذا مثلا 13-03-20 في دالة Mid يجب ان نعرف تسلسل الرقم هنا رقم 1 تسلسله هو 1 ورقم 3 تسلسله 2 وشارحة - الاول تسلسله 3 ورقم 0 مع الاشهر تسلسله 4 ورقم 3 تسلسله 5 وشارحة - الثانية تسلسله 6 ورقم 2 تسلسله 7 ورقم 0 الاخير تسلسله 8 في المربع السنة استخدمنا هكذا =Mid([Feriq];7;2) رقم 7 اي يعني اختر من تستسل 7 وهو رقم 2 ويكون رقمين فقط اي يعني رقم 2 و صفر اي يعني20 وفي المربع الاشهر هذا =Mid([Feriq];4;2) رقم 4 يعني اختر من تسلسل 4 وهو رقم 0 ويكون رقمين اي يكون 0 و 3 اي يعني 03 وفي المربع الايام هذا =Mid([Feriq];1;2) رقم 1 يهني اختر من تسلسل 1 اي يعني 1 ويكون رقمين اي يعني 13 ملاحظة : تقدر تستخدم مصدر النموذج جدول وليس استعلام لكن يجب ان تضيف في النموذج مربع نصي وتكون مصدره كالتالي masdatediffh([تاريخ التعيين];Date()) تحياتي

وعليكم السلام-يمكنك استخدام هذه المعادلة =COUNTIFS(الموجودون!$D:$D,B$2,الموجودون!$G:$G,B$1,الموجودون!$F:$F,$A3) 1.xlsx

السلام عليكم و رحمة الله تعالى و بركاته الى الإحوة الأفاضل هذا الملف و الذي يحتوي على اكواد رائعة . و الذي يحتاجه خاصة الذين يتعاملون مع فروع الشركات التي ترسل ملفات عن طريق الايميل مثلا : لديك نمودج لتقرير ما اسمه repport.xls ترسله الى الفروع ،و عند استقبال الملفات عن طريق الايمل و تحملها تصبح هكذا repport(1).xls ..repport(2).xls...repport(3).xls..الخ . لا يهم أيا كان اسم الملف و تريد اعادة تسمية الملفات بناءا على اسم الفرع في الخلية من كل تقرير . اليك هذا الملف بضعطة زر . تسمية كل الملفات. مهما كان عددها الملفات المرفقة : أمثلة عن تقارير. عند التحميل تجد التقارير و البرنامج 1- أفتح ملف اعادة تسمية الملفات 2- جدد مسار ملفات التقارير التي في المرفق 3- اضغط على جلب اسماء الملفات 4- اضغط على اعادة تسمية. ستلاحظ أن الملفات قد تغيرت أسماءها الى اسم الفرع المرسل. ملاحظة : يمكنك التعديل على الاكواد كما تشاء حسب تصميم تقريرك و السلام عليكم و رحمة الله تعالى و بركاته تسمية.rar

وعليكم السلام -جرب هذا لعله يفيدك برنامج ومنظومة صرافة العملات بحلته وشكله الجديد وهذا ملف اخر برنامج للصرافة المالية الخاصة وهذا برنامج اخر بمقابل مادى برنامج صرافة لإدارة مؤسسات الصرافة

السلام عليكم هذه محاولة ارجو ان تنفعك Root20.rar

حسب ما فهمت انا اتفضل اليك هذه الاكواد Private Sub Command13_Click() Me.TimerInterval = 250 If Me.A = 0 Then Me.A = 1 If Me.B = 0 Then Me.B = 1 End Sub Private Sub Command15_Click() Me.TimerInterval = 0 End Sub Private Sub Form_Timer() If Me.A = 9 Then Me.A = 1 Else Me.A = Me.A + 1 End If If Me.B = 9 Then Me.B = 1 Else Me.B = Me.B + 1 End If End Sub واليك المثال 19 (1).accdb

اتفضل استخدمت هذا الكود اي نماذج بيكون مفتوحة سيدخل له القيمة Private Sub أمر2_Click() If CurrentProject.AllForms("Form2").IsLoaded = True Then Form_form2.نص0 = Me.نص0 ElseIf CurrentProject.AllForms("Form3").IsLoaded = True Then Form_form3.نص0 = Me.نص0 End If DoCmd.Close acForm, Me.Name End Sub مثال اوفيسنا نموذج الحسابات يعمل مع اكثر من نموذج.rar

السلام عليكم-تم انشاء صفحة جديدة بالملف (إدخال البيانات) وتم عمل قائمة منسدلة بالعمود الثانى B بأرقام السيارات , فكل ما عليك فعله هو اختيار رقم السيارة من القائمة وسيقوم الإكسيل بإظهار اسم السائق لتلك السيارة تلقائياً دون تدخل منك وذلك بهذه المعادلة... فمن فضلك لا تقوم بعمل دمج للخلايا لحسن عمل المعادلة =IFERROR(INDEX(الناقلين!$B$3:$B$1000,MATCH($B2,الناقلين!$C$3:$C$1000,0)),"") الناقلين.xlsx

وعليكم السلام ورحمة الله وبركاته واليك التعديل على المرفقك مدة خدمة الموظف.accdb

تفضل لك ما طلبت وهذه أسماء وكلمات السر للمتخدمين مع الصلاحيات ... والصفحة التى بها الفورم الذى تعمل عليه هى صفحة إدخال البيانات ..... وكلمة السر دائماً للدخول لصفحة الصلاحيات هى 123 اسم المستخدم كلمة المرور صفحة الادخال صفحة الاستعلام قاعدة البيانات Yasser 123 yes yes yes aseel 111 yes no yes mohamed 222 no no no بيانات الموظفين.xlsm

بالنسبة لموضوع الصلاحيات فيمكنك متابعة هذا بنفسك من خلال عدة مشاركات بالمنتدى تم تداول هذا الموضوع بها ومنها : برنامج صلاحيات المستخدمين الاصدار 3 حماية ملف اكسل من داخل الملف + صلاحيات لكل مستخدم + سجل لأسماء و مواعيد الدخول للملف شاشة دخول مع صلاحيات برنامج صلاحيات المستخدمين - بشكل جديد نموذج دخول بصلاحيات الاطلاع على أوراق العمل صلاحيات للوصول لشيتات صلاحيات الدخول للمستخدمين وهذه فيديوهات شرح https://www.youtube.com/watch?v=zGopdxUQCQU https://www.youtube.com/watch?v=JxrjmUW_UoA

أخى الكريم جرب هذا تم عمل كمبوبوكس بدلا من التكست بوكس هيكون اسرع بالطبع فى البحث بيانات الموظفين 2020 -1.xlsm

بارك الله فيك وجزاك الله خير الثواب

وعليكم السلام-بارك الله فيك وجزاك الله كل خير

بارك الله فيك وجزاك الله كل خير

السلام عليكم و رحمة الله وبركاته تم تنفيذ الكود المطلوب Sub az() ' Dim FS As Worksheet, TS As Worksheet Dim FC, FR, TR, ER, Q1, Q2, Q3, SH Set FS = Sheets("أمور الشغل") ER = FS.UsedRange.Rows.Count For FR = 2 To ER Q1 = FS.Cells(FR, 4).Text ' المعدة Q2 = FS.Cells(FR, 1).Value ' رقم امر التشغيل For SH = 1 To ActiveWorkbook.Sheets.Count If Sheets(SH).Name = Q1 Then Set TS = Sheets(SH) ' ورقة السيارة Q3 = Application.CountIf(TS.Range("A:A"), Q2) If Q3 > 0 Then GoTo 3 TR = Application.CountA(TS.Range("A:A")) 4 If TS.Cells(TR, 1) <> "" Then TR = TR + 1 GoTo 4 End If For FC = 1 To 12 TS.Cells(TR, FC) = FS.Cells(FR, FC) Next FC End If Next SH 3 Next FR End Sub و لكن نصيحة الاسهل هو استخدام الجداول المحورية او استخدام التصفية التلقائية او استخدام التصفية المتقدمة بالكود و هذه الحلول افضل من استخدام الكود الموضح اعلاه تحافظ على حجم الملف صغير و كل تعديل في بيانات الورقة الاولى يظهر فورا ولك حرية الاختيار شيت امور الشغل.xls

جزاك الله كل خير على هذا الشرح الوافى اخى شفان ريكاني

أخى الكريم mrsadek2000 تم تناول ومناقشة هذا البرنامج من قبل على هذا الرابط برنامج الحسابات العامة والمخازن والمقاولات-The Fastest

السلام عليكم ربما هذا المثال هو المطلوب بالتوفيق إن شاء الله الموظفين.accdb

وعليكم السلام اخوي عبداللطيف 🙂 هذا الرابط فيه وحدة نمطية لطلبك 🙂 https://www.officena.net/ib/topic/80943-كيفية-حساب-عدد-الاشهر-بين-تاريخين/ جعفر

السلام عليك تفضل اخي العزيز ارجو ان يكون طلبك نقل فورم.rar

جزاك الله كل خير استاذ محمد والف مليون مبـــــروك ومن تقدم الى تفوق دائما ان شاء الله الى الأمام

وعليكم السلام -بعد اذنك استاذ سليم ... ولما اصلاً لا تقوم بإستخدام خاصية البحث بالمنتدى -تفضل الوارد اولا صادر اولا (first in first out (FIFO

بمجرد أن يكون اليوم أكبر من أو يساوي 12 غالبا تنتهي مشاكل التاريخ بسبب الخلط بين اليوم والشهر متأثرا بتنسيق نظام التشغيل. ولكن إذا قل اليوم عن 12 وهو القيمة الكبرى للشهور تبدأ أحيانا مشاكل الخلط وبالتالي اختلاف قيمة التاريخ وخصوصا إذا كتب التاريخ على شكل نص وحصره بعلامتي الرقم #. طريقتي في الاحتراز: تحويل التاريخ إلى رقم باستخدام أربع دوال كالتالي: - إذا كان التاريخ بدون وقت يمكن استخدام دالة CLng. - إذا كان التاريخ يحتوي على وقت ينصح باستخدام دالة CDbl. - إذا كان التاريخ على شكل نص مثل #10/04/2020# وهذا أخطرها ينصح باستخدام دالة DateSerial ليصبح DateSerial(2020, 4, 10). - وإذا كان على شكل نص ويحتوي على وقت مثل #10/4/2020 11:43:30 PM# ينصح بإضافة دالة TimeSerial ليصبح DateSerial(2020, 4, 10) + TimeSerial(23, 43, 30). قد يستثقلها المبرمج ويرى فيها تعقيدا ولكن كاحتراز فهي مطلوبة بشدة وخصوصا إذا كانت البرامج لها علاقة بحسابات وأمور يترتب علي أخطائها أضرارا. هذا اجتهادي وقد أكون صائبا وقد أكون مخطئا.

اخي الكريم السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير هل يراودك شك احيانا في بعض الكلمات او الرموز عند تسمية الحقول هل هي محجوزة أم لا ؟ اليك الحل هدية العيد : في المرفقات تطبيق بحثي يشتمل على جميع كلمات ورموز الاكسس المحجوزة والتي يجب أخذ الحيطة عند تسمة الحقول واجتناب التسمية بها لان ذلك يؤدي الى ظهور أخطاء أمام المبرمج يخفى عليه سببها . آمل ان تجدوا الفائدة ،،، dbx.rar

السلام عليكم ورحمة الله جرب المرفق لعل فيه ما تريد... إيجاد درس المراجعة.xlsx

@فايز.. تفضل Dim strSearch As String static xn Dim rs As Object Set rs = Me.RecordsetClone If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then MsgBox "رجاء ادخل اسم للبحث عنه", vbOKOnly, "خطأ في البحث" Me![txtSearch].SetFocus Exit Sub End If strSearch = Me![txtSearch] With rs .FindNext "[EmpName] like '*" & strSearch & "*'" If Not .EmpName Like "*" & strSearch & "*" Then MsgBox "لا يوجد سجل بهذا الإسم : " & strSearch, , "غير موجود" Me.txtSearch = "" Me![txtSearch].SetFocus ElseIf .NoMatch Then MsgBox "آخر سجل في البحث عن : " & strSearch, , "آخر سجل" Me.cmdSearch.Caption = "بحث" Me.txtSearch = "" Me![txtSearch].SetFocus Me.cmdSearch.ForeColor = RGB(0, 0, 255) DoCmd.GoToRecord , , acFirst Else xn=xn+1 Me.Bookmark = .Bookmark if xn=1 then MsgBox "تم ايجاد اسم : " & strSearch, , "مبروك" Me.cmdSearch.Caption = "اكمال البحث" Me.cmdSearch.ForeColor = RGB(255, 0, 0) End If End With rs.Close Set rs = Nothing بالتوفيق

السلام علبكم تفصل اخي الكريم بالتوفيق test-Copy2.rar

اشكركم على المرور جميعا ارى حل الاخ شيفان اسهل وافضل مع احترامي لكم جميعا

اللون الاصفر يشير إلى التواريخ التي اخترتها (بين تاريخين) بالنسبة للكليندر يجب وضع 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

@فايز.. ممكن عمل طلبك ولكن هي مفيده لو اصبح لديك اكثر من سجل يطابق بحثك ؟ فلايجاد المطابق الثاني ستنقر على "اكمال البحث" وهكذا حتى تنتهي الى اخر سجل وسيتم تنبيهك كذلك ؟ وهنا سر الفكرة الزهريه وصدقني انا لما مريت هنا هو اعجابي بالكود الزهري . هذا وان كنت متاكد من رغبتك في ازالة المسج عد وسنعود ! تحياتي

للاسف مش زابطة معي شاهد هذا الفيديو وطبق

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

لو احترزنا بـ : - عمل تنسيق لصندوق النص. - عمل ماسك عند الرغبة في منع المستخدم باختصار السنة بأني يكتب 1 بدلا من 2001 مثلا. - عمل نطاق للتاريخ في التحقق من صحة التاريخ Validation. وإن استطاع الإفلات من كل هذه الاحترازات نضع هذا الكود في حدث قبل التحديث لصندوق النص: Private Sub txtTestDate_BeforeUpdate(Cancel As Integer) Dim DateText As String, Char As String Dim DateLen As Byte, Pos As Byte Dim yy As Integer, mm As Integer, dd As Integer On Error Resume Next DateText = Me.txtTestDate.Text If Trim(DateText) = "" Then Exit Sub DateLen = Len(DateText) For Pos = 1 To DateLen Char = Mid(DateText, Pos, 1) If Not Char Like "[0-9]" Then DateText = Replace(DateText, Char, "/") End If Next Pos Do While InStr(1, DateText, "//") > 0 DateText = Replace(DateText, "//", "/") Loop Pos = InStr(1, DateText, "/") dd = Left(DateText, Pos - 1) DateText = Mid(DateText, Pos + 1) Pos = InStr(1, DateText, "/") mm = Left(DateText, Pos - 1) yy = Mid(DateText, Pos + 1) 'يمكنكم تبديل النطاق If yy < 1900 Or yy > 9999 Then MsgBox "السنة خارج النطاق" Cancel = True Exit Sub End If If mm < 1 Or mm > 12 Then MsgBox "الشهر خاطئ" Cancel = True Exit Sub End If If dd < 1 Or dd > Day(DateSerial(yy, mm + 1, 0)) Then MsgBox "اليوم خاطئ" Cancel = True Exit Sub End If End Sub فلنجرب ولنحكم قبضتنا على المستخدم وإذا ما نجحنا فنشناه وبدلناه بموظف مخه في راسه.

شوف هنا لمعلومات اكثر حيث اكتب من الموبايل يمكن تختصر ب currentdb.properties(“allowfullmenus”)=false بالتوفيق

وعليكم السلام جزاه الله خيرا اخى خالد @Khalid Jnb من المفروض ذكر هذه النقط بالبدايه هل ياتى على ملف اكسيل ام اكسيس يجب ان نراه حتى نعلم كيف سنتعامل مع البيانات بشكل كامل ضعى لنا الملف الذى ياتى وبه بعض البيانات حت ولو وهميه او كاضافات للبيانات الموجوده بالمثال هنا فى استقطاعات هتضاف للموجودين وفى موظفين جدد هينضافوا فى انتظار الملف الاخر الذى يرد اليك @duaasafaa حتى يستطيع اخوانك واساتذتنا تقديم المساعده بافضل الحلول الممكنه وارجو تعديل افضل اجابه لاخى خالد كما كانت فضلا لاامرا بالتوفيق ان شاء الله

قنوات تعليمية شخصية و دورات تدريبية مجانية و مدفوعة السلام عليكم تم اضافة قسم جديد على سبيل التجربة ، الغرض من القسم اضافة المشاركات ذات الطابع الاعلاني سواء كان إعلان عن دورات تدريبية أو دعاية بغرض نشر مشاركات قنوات شخصية تعليمية ( فى حال لم يرغب صاحب المشاركة فى التفاعل مع الأعضاء حولها و كان فقط يريد الدعاية و نشر درس على قناته فى اليوتيوب على ان تكون دروس تعليمية مفيدة فى مجال الموقع) أما المشاركات التي تحوي نشر وصلات دروس تعليمية على اليوتيوب و يتم التفاعل مع تساؤلات الأعضاء بخصوصها عند نشرها فلا ينطبق عليها النقل لهذا القسم و انما مكانها فى القسم المناظر كما هو معتاد ويمكن أيضا جمعها فى مدونة يقوم صاحب القناة باعدادها لهذا الغرض لإذا كان من المجموعات المسموح لها بإنشاء مدونات خاصة بالموقع مشاركات إعلانات شركات التدريب فى هذا القسم، سيتم حذفها بعد فترة زمنية كافية حتى تبقي فقط الاعلانات الحديثة و لا تكون هناك اعلانات قديمة غير محدثة. قنوات تعليمية شخصية و دورات تدريبية مجانية و مدفوعة قسم خاص لاعلانات القنوات الشخصية و الدورات التدريبية المجانية أو التي تقدمها شركات تدريب ولا يسمح بالرد أو التفاعل او تحميل الملفات حيث أن الموقع لا يتحمل أي مسئولية من أي . نوع عن هذه الاعلانات . يتم تفريغ المحتوى دوريا ، و لا يسمج بالتكرار و هذا القسم كما ذكرنا تم استحداثه على سبيل التجربة و هو حاليا قيد التجربة و التقييم وبالطبع هذا القسم يختلف عن قسم الإعلانات الشخصية للأعضاء و الذي يختص بالمشاركات الخاصة بالوظائف و طلبات البرامح أو الحلول مدفوعة الأجر إعلانات شخصية بأجر للاعضاء هذا القسم مخصص لاعلانات الاعضاء الخاصة سواء طلب برنامج او عرض عمل برنامج او طلب وظيفة او عرض وظيفة تتعلق بالاوفيس او البرمجة، و على الطالب وضع وسائل الاتصال به ، ولا يسمح بالرد او تحميل الملفات حيث أن الموقع لا يتحمل أي مسئولية من أي نوع عن هذه الطلبات. . يتم تفريغ المحتوى دوريا ، و لا يسمج بالتكرار وكلا القسمين لا يسمح بالتفاعل فيهما بعكس باقي أقسام المنتدى، و لا يمكن الرد على المشاركات ، و انما فقط هي خدمة إعلانية نقدمها تسهيلا على الأعضاء دون أدني مسؤولية على الموقع، و انما يتم التواصل و الاتفاق بين المعلن و من يرغب بالحصول على الخدمة أو الدروس المدفوعة أو الاستفادة من الدروس المجانية.

جرب هذا الكود Option Explicit Sub Colorize_Dupicates() Dim Sh As Worksheet, A As Worksheet Dim Rg As Range, cel As Range, _ Act_Rg As Range, F_rg As Range Dim Fadr$, Sadr$ Dim D As Object Dim i%, X%, y% Set Sh = ActiveSheet Set Rg = Sh.Range("a1").CurrentRegion.Columns(1).Cells X = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Range("C1:z" & X).Clear Set D = CreateObject("Scripting.Dictionary") Rg.Interior.ColorIndex = xlNone For Each A In Sheets A.Range("a1").CurrentRegion.Columns(1) _ .Interior.ColorIndex = xlNone A.Range("C1:z100").Clear Next For Each cel In Rg For Each A In Sheets If A.Name <> Sh.Name Then Set Act_Rg = A.Range("a1").CurrentRegion.Columns(1) X = A.Cells(Rows.Count, 1).End(3).Row Set F_rg = Act_Rg.Find(cel, lookat:=1) If F_rg Is Nothing Then GoTo Next_A cel.Interior.ColorIndex = 6 Fadr = F_rg.Address: Sadr = Fadr Do F_rg.Interior.ColorIndex = 6 D(A.Name & " :Row (" & F_rg.Row & ")") = vbNullString Set F_rg = Act_Rg.FindNext(F_rg) Sadr = F_rg.Address If Sadr = Fadr Then Exit Do Loop End If Next_A: Next A If D.Count > 0 Then With cel.Offset(, 2).Resize(, D.Count) .Value = D.keys .Borders.LineStyle = 1 .Interior.ColorIndex = 38 .InsertIndent 1 End With With cel.Offset(, 2 + D.Count) .Value = IIf(D.Count = 1, "1 Duplicate", D.Count & " Duplicates") .Borders.LineStyle = 1 .Interior.ColorIndex = 6 .InsertIndent 1 End With Else With cel.Offset(, 2) .Value = "No Duplicates" .Borders.LineStyle = 1 .Interior.Color = vbGreen .InsertIndent 1 End With End If D.RemoveAll Next cel End Sub الملف مرفق Count_Tekrars.xlsm

وعليكم السلام أخى الكريم .... رجاءا من الجميع الإلتزام بتعليمات وقوانين المنتدى ,فقد نبهنا مئات المرات ان لا تقوم برفع وعرض مشاركة جديدة الا بعد التأكد ان طلبك لم تم مناقشته وتداوله مسبقا داخل المنتدى فكان عليك استخدام خاصية البحث قبل انشاء هذه المشاركة -تفضل تلوين خلية بجميع اوراق العمل اذا تكررت في اي ورقة عمل وهذا موضوع ايضا اخر مختلف لعدم تكرار البيانات المدخلة فى كل صفحات الملف عدم تكرار البيانات المدخلة في كل الشيتات جزاك الله كل خير

اللهم آمين اللهم امين جزاكم الله خيرا اخوانى واساتذتى اتفضل اخى هاوى الرابط اللذى اشار اليه اخى واستاذى خالد @kha9009lid جزاكم الله خيرا

لفتت نظري هذه الطريقة واردت التأكد من فاعليتها قمت بعمل حلقة تكرارية لتوليد 50000 سجل تاريخ لعدد اربعة حقول كل منها بتنسيق مختلف ومن ثم عملت مقارنة في قيمة الحقول الاربعة بعد تحويل التاريخ الى رقم وكانت النتيجة ممتازة مع ذلك النتيجة هنا قد لا تكون حاسمة لكون التاريخ يتأثر بصيغة التاريخ في نظام التشغيل لذك قمت بنقل المثال على الشبكة وقمت بتغيير صيغة التاريخ في الاجهزة المتصلة وكانت النتيجة ايضا ممتازة في المقارنة وفي البحث وفي معايير دوال التجميع مع ذلك الطريقة التي استخدمها Format([da_te];"\#mm\/dd\/yyyy\#") تعطي نفس النتيجة وكذلك الوحدة الخاصة بالاستاذ @jjafferr تعطي نفس النتيجة وتمتاز من وجهه نظري بالسهولة DateFormat([d_date]) في الحقيقة من اجمل المواضيع التي شدت انتباهي

السلام عليكم ورحمة الله ضع هذا الكود فى حدث ThisWorkbook Private Sub Workbook_SheetActivate(ByVal Sh As Object) For i = 1 To Sheets.Count Sheets(i).Range("A1").Value = i Next End Sub

مجرد الاختيار من القائمة يتم تعبئة العمود b تلقائي المطلوب.xlsm

في كل الاكواد داخل الملف استبدل حرف A الى اسم العامود الذي تريده

تم التعديل على الماكرو بحيث يعطينا اين يوجد التكرار (اسم الصفحة مع رقم الصف) Tekrar_by_sheets_Address.xlsm

يمكن اضافة هذا الكود الى حدث Workbook ليعمل كما تريد Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Sh.Range("A1").CurrentRegion.Columns(1)) Is Nothing And _ Target.Count = 1 Then Colorize End If Application.EnableEvents = True End Sub الملف مرفق Auto_Tekrar_by_sheets.xlsm

Try This macro Option Explicit Sub Colorize() Dim Sh As Worksheet Set Sh = ActiveSheet Dim Rg As Range, cel As Range Dim at_c As Worksheet Dim Fadr$, Sadr$, i% Dim Act_Rg As Range, F_rg As Range Set Rg = Sh.Range("a1").CurrentRegion.Columns(1).Cells Rg.Interior.ColorIndex = xlNone For i = 1 To Sheets.Count If Sheets(i).Name <> Sh.Name Then Set Act_Rg = Sheets(i).Range("a1").CurrentRegion.Columns(1) Act_Rg.Interior.ColorIndex = xlNone For Each cel In Rg Set F_rg = Act_Rg.Find(cel, lookat:=1) If F_rg Is Nothing Then GoTo Next_cel cel.Interior.ColorIndex = 6 Fadr = F_rg.Address: Sadr = Fadr Do F_rg.Interior.ColorIndex = 6 Set F_rg = Act_Rg.FindNext(F_rg) Sadr = F_rg.Address If Sadr = Fadr Then Exit Do Loop Next_cel: Next cel End If Next i End Sub File Included Tekrar_by_sheets.xlsm

جرب هذا الملف Ages.xlsx

بسم الله الرحمن الرحيم طلب بعض الاخوة موضوع الوارد اولا صادر اولا (FIFO) قمنا بعمل مثال بالاكواد لحل هذه المشكلة المثال يعتمد على اعمدة مساعدة ويتم مسح البيانات منها بعد الانتهاء الكود المستخدم Sub YasserFIFO() Dim z As Byte Application.ScreenUpdating = False Range("K6:K23").ClearContents Range("D6:E23").Copy Range("R1") Range("r1:s18").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp Range("G6:G23").Copy Range("T1") z = 1 For Each x In Range("g6:g23") If x.Value <> "" Then If x.Value <= Cells(z, 18) Then Cells(x.Row, 11) = Cells(z, 19) * x.Value Cells(z, 18) = Cells(z, 18) - x.Value ElseIf x.Value > Cells(z, 18) Then 3 Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 18) * Cells(z, 19)) x.Value = x.Value - Cells(z, 18) Cells(z, 18) = 0 For z = 1 To 20 If Cells(z, 18) = 0 Then GoTo 1 If Cells(z, 18) >= x.Value Then GoTo 2 If Cells(z, 18) < x.Value Then GoTo 3 1 Next z 2 Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 19) * x.Value) Cells(z, 18) = Cells(z, 18) - x.Value End If End If Next Range("T1:T18").Copy Range("G6:G23") Range("R1:T18").Clear Range("a1").Activate Application.ScreenUpdating = True End Sub ومرفق المثال تستطيعوا تكبير المدى او جعله مرن بالتعديل على النطاقات الموجودة بالكود FiFo_2.rar