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

استخدمنا هذه الفانكشن 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

تفضل اخي @فايز.. والشكر موصول للاستاذ @ابوآمنة مزحه : تقول ماشفتها وانا لقيتها في ملغك الاخير هذا اخي فايز تحياتي للجميع Posters.accdb

ياسلام عليك @ابوآمنة وزياده شوية نضيف xn=0 بعد rs.movefirst لكي برضه رساله واحده للبحث الثاني بالتوفيق

مساهمة مع أخي رمهان أضف بعد هذه هذه السطر DoCmd.GoToRecord , , acFirst هذا الكود rs.MoveFirst شاهد المرفق Posters5.zip

شكرا جزبلا استاذنا ربنا يبارك فى حضرتك جزاءاك الله كل خير

السلام عليكم و رحمة الله و بركاته ماهو شرط عدم التكرار مثلا عدم تكرار امر الشغل او غيره

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

جزاك الله خيرا

اخي مطمئن عليك بطرح موضوع جديد بناء على العنوان وطلبك قمنا بحل المشكلة طرح موضوع جديد يسهل عليك وعلى الاساتدة للتفاعل معك تحياتي

وعليكم السلام ... يمكنك متابعة هذا الموضوع ضبط المسافات بين الكلمات

وعليكم السلام أخى الكريم لما لا تقوم بإستخدام خاصية البحث بالمنتدى طالما لم تقم برفع ملف بالمطلوب ؟ تفضل مُجمِع البيانات للاكسيل - Excel Data Collector الإصدار الخامس دمج وتجميع عدة ملفات خارجية فى ملف واحد بالمعادلات وهذا رابط اخر دمج ملفات اكسل في ملف واحد وهذا كود اخر لهذا الموضوع Sub MergeExcelFiles() 'https://www.ablebits.com/office-addins-blog/2017/11/08/merge-multiple-excel-files-into-one/ Dim fnameList, fnameCurFile As Variant Dim countFiles, countSheets As Integer Dim wksCurSheet As Worksheet Dim wbkCurBook, wbkSrcBook As Workbook fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True) If (vbBoolean <> VarType(fnameList)) Then If (UBound(fnameList) > 0) Then countFiles = 0 countSheets = 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set wbkCurBook = ActiveWorkbook For Each fnameCurFile In fnameList countFiles = countFiles + 1 Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile) For Each wksCurSheet In wbkSrcBook.Sheets countSheets = countSheets + 1 wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count) Next wbkSrcBook.Close SaveChanges:=False Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files" End If Else MsgBox "No files selected", Title:="Merge Excel files" End If End Sub وهذا كود ثانى للمطلوب Sub ConslidateWorkbooks() 'https://trumpexcel.com/combine-multiple-workbooks-one-excel-workbooks/ Dim FolderPath As String Dim Filename As String Dim Sheet As Worksheet Application.ScreenUpdating = False FolderPath = Environ("userprofile") & "DesktopTest" Filename = Dir(FolderPath & "*.xls*") Do While Filename <> "" Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True For Each Sheet In ActiveWorkbook.Sheets Sheet.Copy After:=ThisWorkbook.Sheets(1) Next Sheet Workbooks(Filename).Close Filename = Dir() Loop Application.ScreenUpdating = True End Sub

بارك الله فيك أستاذ الرائد77 .... عمل ممتاز جعله الله فى ميزان حسناتك أخى عبدالفتاح في بي اكسيل وذلك لأنك لم تقم بتغيير مسار فولدر التقارير بما يتناسب مع جهاز الكمبيوتر لديك

وعليكم السلام 🙂 نعم هذا صحيح ، فيجب ان لا نستعمل الكلمات المحجوزة للاكسس ، وهنا قام اخوي ابوخليل بوضع مرفق للأسماء المحجوزة ، فيه كذلك رابط مُعرّب : جعفر

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

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

لم يكن طلبك واضح من البداية يا أخي لا بأس تفضل . اضافة العنصر المختار من ليست بوكس 3 الى العمود h ; و الليست 2 الى i يمكنك التغييير ادا اردت في الكود Sample (1).xlsm

وعليكم السلام اخى @husamwahab منور جزاك الله خيرا زياده الخير خيرين ومنى تعديل طفيف عالسابق بعد تجربته لم يكن يسجل القيم فعدلته بتعديل طفيف استفدته من اخى واستاذى @kha9009lid جزاه الله خيرا بالتوفيق اخوانى مربح تحرير وسرد(1).accdb أحسنت اخى حسام جزاك الله خيرا

السلامة عليكم من رخصة الاستاذ أحمد الفلاحجى هذه مشاركة مني Root15.rar

تفضل test.xlsx

تفضل اخي مع هذا الماكرو البسيط لاتقم ثانية بدمج الخلايا لان الكود لايعمل ضع القيمة في الخلية g3 Sub abdelfattah() Dim NxtRw As Long On Error Resume Next NxtRw = Range("C5:C16").SpecialCells(xlBlanks)(1).Row On Error GoTo 0 If NxtRw = 0 Then Exit Sub Range("C" & NxtRw).Value = Range("G3").Value Range("G3").Value = "" End Sub Classeur STE (1).xls

@فايز.. @ابوآمنة هذا تعديل على كود الاستاذه زهره ولماطلبت بنفس الرسائل Dim strSearch As String 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 Me.Bookmark = .Bookmark MsgBox "تم ايجاد اسم : " & strSearch, , "مبروك" Me.cmdSearch.Caption = "اكمال البحث" Me.cmdSearch.ForeColor = RGB(255, 0, 0) End If End With rs.Close Set rs = Nothing بالتوفيق

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

لم أتعود على كتابة الأمثلة وهذه مقدرتي ، من يمتلك هذه الملكة فليقوم بالاختبارات وعمل أمثلة أكثر وضوحا. من أهم ما أشدد على الالتزام به هو أن تستخدم دالة تحويل التاريخ إلى رقم لجهتي المقارنة أي حقل الجدول و قيمة البحث. Sub Test4() Dim TestDate As Date Dim SearchText As String '----------------------------------------------------------- 'المعتاد SearchText = "Birthdate=" & #10/4/2020# 'الاحترازي TestDate = DateSerial(2020, 4, 10) SearchText = "CLng(Birthdate)=" & CLng(TestDate) '-------------------------------------------------------- 'المعتاد SearchText = "Birthdate=" & #10/4/2020 11:43:30 PM# 'الاحترازي TestDate = DateSerial(2020, 4, 10) + TimeSerial(23, 43, 30) SearchText = "CDbl(Birthdate)=" & CDbl(TestDate) End Sub Sub Test5() Dim SearchText As String SearchText = #10/4/2020# Debug.Print CDate(SearchText) 'الناتج 04/10/2020 Debug.Print DateSerial(2020, 4, 10) 'الناتج 10/04/2020 '-------------------------------------------------------- SearchText = #4/13/2020# 'كتبتها 13/4/2020 وحولها المحرر 4/13/2020 Debug.Print CDate(SearchText) 'الناتج 13/04/2020 Debug.Print DateSerial(2020, 4, 13) 'الناتج 13/04/2020 End Sub

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

ما عليك الا اضافة 1 (او اي رقم تريده) الى المعادلة كي تصبح هكذا =IF(OR(A2="",B2=""),"",DATEDIF(DATE(B2,1,1),TODAY(),"y")+1)

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

جرب هذا الماكرو Option Explicit Sub ABSCENT() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 2) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "Q") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub الملف مرفق Tarhil_3iyab.xlsm

ورد خطأ بسيط في الملف السابق ارجو المعذرة اليك الكود الصحيح مع الملف المرفق الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Or Target.Address = "$A$2" Then With Application .ScreenUpdating = False .EnableEvents = False End With Dim i%, t%, y% Dim eom As Date eom = Evaluate("EOMONTH(DATE($A$1,$A$2,1),0)") y = Day(eom) Columns("G:ak").Hidden = False ' hid_Vacance For i = 35 To 37 If Cells(14, i) = vbNullString Then Cells(1, i).EntireColumn.Hidden = True End If Next hid_Vacance For i = 7 To 37 If Cells(15, i).Columns.Hidden = True Or Cells(15, i) = Cells(3, 1) Then t = t + 1 End If Next Cells(5, 2) = y - t End If With Application Application.ScreenUpdating = True Application.EnableEvents = True End With End Sub '=============================================== Sub hid_Vacance() Application.EnableEvents = False Dim lraz%: lraz = Cells(Rows.Count, "AZ").End(3).Row Dim match%, x%, tt% Dim yes As Boolean For tt = 2 To lraz yes = IsError(Application.match(Range("AZ" & tt), Range("g14:aK14"), 0)) If Not yes Then x = Application.match(Range("AZ" & tt), Range("g14:aK14"), 0) + 6 Cells(14, x).EntireColumn.Hidden = True End If Next Application.EnableEvents = True End Sub الملف الجديد كشف Salim A3yad2 .xlsm