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

اعرض الملف 🎁 :: مرسال الواتسأب :: 📨 :: الإصدار الثاني 2.0 :: مطور :: 🧬🏹 السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مرسال الواتسأب) مع المرفقات مرسال الواتسأب مع المرفقات | سلسلة هدايا الأكسس | 03| 🎁 وهو عبارة عن برنامج صغير لإرسال الرسائل للواتسأب مع المرفقات .. :: من مميزات هذا الإصدار :: - إرسال رسائل فردية أو جماعية عن طريق برنامج الواتسأب . - لا يحتاج لبرنامج الإنترنت إكسبلورر لفتح الواتسأب. - لا يغلق مفتاح الـ NumLock بعد الإرسال. -تم اختصار الكود في موديول واحد ودالة واحدة تقوم بعملية الإرسال بعدة خيارات . - لو أردت تطبيق الكود في برنامجك الخاص ستحتاج لنقل الموديول إلى برنامجك + سطر برمجي واحد فقط لعملية الإرسال. :: شرح البرنامج :: :: لتحميل البرنامج :: صاحب الملف Moosak تمت الاضافه 30 مار, 2023 الاقسام قسم الأكسيس

سلمت يمينك يا استاذ👌🌹 @محمد يوسف ابو يوسف

For Excel 365, use the following formula in cell D11 (Clear the range first from D11 to D25) then put the formula =TEXT(FILTER(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),WEEKDAY(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),1)>=6),"ddd") In cell E11, use the formula =TEXT(FILTER(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),WEEKDAY(SEQUENCE(DAY(EOMONTH(K6,0)),,EOMONTH(K6,-1)+1,1),1)>=6),"dd/mm/yyyy") For older version of excel ------------------------------- In cell D11, use the formula =IF(MONTH($K$6-MOD(WEEKDAY($K$6,1)-6-IF(WEEKDAY(DATE(YEAR($K$6),MONTH($K$6),1),1)=7,1,0),7)+IF(WEEKDAY($K$6,1)<6,7,0)+7*(INT((ROW()-11)/2)))=MONTH($K$6),$K$6-MOD(WEEKDAY($K$6,1)-6-IF(WEEKDAY(DATE(YEAR($K$6),MONTH($K$6),1),1)=7,1,0),7)+IF(WEEKDAY($K$6,1)<6,7,0)+7*(INT((ROW()-11)/2)),"") In cell D12, use the formula =IFERROR(IF(MONTH(IF(WEEKDAY(E11)=6,E11+1,IF(WEEKDAY(E11)=7,E11+6,"")))>MONTH($K$6),"",IF(WEEKDAY(E11)=6,E11+1,IF(WEEKDAY(E11)=7,E11+6,""))),"") Select the cells D11 & D12 and drag them Do the same exactly for E11 & E12

السلام عليكم أخي @bidheel2009 🙂 إن كان هذا البرنامج من تصميمك ياريت لو تسوق له بشكل جيد .. ضع بعض الصور مثلا .. أو اشرح مميزات البرنامج .. أو الجهود التي بذلتها فيه .. يعني كلمتين حلوين يشدوا القارئ .. 🙂

للنسخة العادية من الواتسأب غير متاح .. ولكن للنسخة التجارية المدفوعة يمكن عن طريق دوال ال Api الخاصة بشركة الواتسأب .. هذه يمكنك فعلها بسهولة .. قبل مناداة الدالة التي ذكرتها .. قم بتجميع البيانات التي تريد إرسالها للأشخاص في متغير واحد (بحيث تتغير الرسالة لكل شخص) ثم أرسله لدالة الواتسأب لإرسالها بالشكل النهائي .. ( يحتاجلك تتعلم هذه المهارات سهلة 😉👌🏼 ) هذه لا علم لي بها بعد .. 🙂

:: إضـــــافـــة :: هذا هو الموديول الذي يمكنك نقله إلى برنامجك الخاص ومناداته باسم الدالة .. Option Compare Database Option Explicit Enum AttacmentsType Image = 1 Sticker = 2 Document = 3 End Enum #If VBA7 Or Win64 Then Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #Else Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #End If Private Const VK_NUMLOCK = &H90 Public Sub SendToWhatsApp(txtPhone As String, txtMSG As String, Optional txtAttchmentPath As String = "", Optional AttachmentType As AttacmentsType = Image) '---------------------------------------(التحقق من اكتمال البيانات) If Len(txtMSG & "") = 0 Then MsgBox "يرجى كتابة الرسالة": Exit Sub If txtAttchmentPath <> "" Then If Len(Dir(txtAttchmentPath, vbDirectory)) = 0 Then MsgBox "المرفق غير موجود .. تأكد من الرابط": Exit Sub End If txtMSG = Replace(txtMSG, vbCrLf, " %0a ") txtMSG = Replace(txtMSG, Chr(10), " %0a ") txtMSG = Replace(txtMSG, Chr(13), " %0a ") '---------------------------------------(بداية الإرسال) Dim Path As String Path = "whatsapp://send?phone=" & txtPhone & "&text=" & txtMSG CreateObject("Shell.Application").Namespace(0).ParseName(Path).InvokeVerb "Open" ' إرسال الرسالة Sleep 2000 SendKeys "~" Sleep 500 SendKeys "~" ' إرسال المرفق إن وجد If txtAttchmentPath <> "" Then SendKeys "+{TAB}" SendKeys "~" Sleep 1000 Select Case AttachmentType Case Is = 1 ' صورة SendKeys "{UP}" ' لإرسال الصور ' SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 2 ' ملصق SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 3 ' مستند SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال End Select SendKeys "~" Sleep 1000 SendKeys txtAttchmentPath, True SendKeys "~" Sleep 2000 SendKeys "~" Sleep 1000 SendKeys "~" End If 'If NumLock is off, turn it on If GetKeyState(VK_NUMLOCK) = 0 Then 'Send NumLock key press to turn it on SendKeys "{NUMLOCK}" End If '---------------------------------------( إعادة التركيز لبرنامج الأكسس) SetForegroundWindow Application.hWndAccessApp ' MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" End Sub وهكذا تنادي الدالة : SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image

السلام عليكم 🙂 اذا عندنا تقرير بهذه الطريقة: . اليس الافضل دمج بيانات الحقل المتكررة عموديا في حقل واحد ، مثل الوورد مثلا الى : . طريقة العمل : 1. اعمل تقريرك بالطريقة اللي تراها مناسبة ، بالفرز والتصفية : . او بالمجاميع : . 2. ولكن قم بوضع جميع الحقول في قسم "التفصيل" Detail : . 3. ثم اجعل برواز جميع حقول هذا القسم شفافة . 4. ثم الحقول التي تريد دمجها ، اخفاء المتكرر = نعم ، Hide Duplicates = Yes . 5. ثم ضع هذه الاحداث للتقرير Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer) 'Border color not set, use field ForeColor Call Detail_Print_Run_All(5, "'اليوم', 'التاريخ','الزمن'") End Sub Private Sub Report_Open(Cancel As Integer) Call Report_Open_Run(Me.Name) End Sub Private Sub Report_Close() On Error Resume Next Set ctl_ReSize = Nothing End Sub Private Sub Report_Page() Call Report_Page_Run End Sub . 6. لا تحتاج الى عمل اي تغيير في الاحداث اعلاه ، فقط انسخها من هنا والصقها في تقريرك ، ما عدا اول جزء : عرض البرواز ، حيث نخبره باسماء الحقل/الحقول التي نريد دمجها عموديا ، لون البرواز يكون حسب اللون الذي نكتبه ، او اذا لم نكتب لون البرواز ، فلون البرواز سيكون لون نص الكلمات في الحقل . 7. نسخ الوحدة النمطية mod_Report_Field_Hieght_ReSize الى تقريرك ن وكذلك بدون عمل اي تغيير فيها : Option Compare Database Option Explicit Dim rpt_Name_ReSize As String Dim rgb_Border_ReSize As Long, ini_rgb_Border_ReSize As Long Dim Detail_Calc_Height_ReSize As Long Dim Exclude_fld_Name_ReSize As String Dim Add_H_Each_Record_ReSize As Boolean Dim fildMaxHeight_ReSize As Long Dim myDrawWidth As Integer Public ctl_ReSize As Control Dim i_ReSize As Integer, j_ReSize As Integer Dim x_ReSize() As String, tmp_ReSize As String Dim Count_Pages_ReSize As Integer Dim sfld_Name_ReSize() As String, sfld_Value_ReSize() As String, _ sfld_Count_ReSize() As Integer Dim L_ReSize As Single, T_ReSize As Single, W_ReSize As Single, H_ReSize As Single ' Function Detail_Print_Run_All(LineWidth As Integer, myFields As String, Optional border_Color As Long = 1) 'we can this Function in the following ways, indicating Border Color 'Call Detail_Print_Run_All(5, "'c1', 'save', 'b1'", RGB(0, 0, 0)) 'Border color is RGB Value 'Call Detail_Print_Run_All(5, "'c1', 'save', 'b1'", vbBlack) 'Border color is Black 'Call Detail_Print_Run_All(5,"'c1', 'save', 'b1'", vbMagenta) 'Border color is Magenta 'Call Detail_Print_Run_All(5,"'c1', 'save', 'b1'") 'Border color not set, use field ForeColor 'Call Detail_Print_Run_All(5,"'b1'", RGB(0, 0, 0)) '5 is Line Width 'we get most the Lines drawn in Detail Section, 'except for the Last Record in each page, where we use Report Page event (the last page is easy) ini_rgb_Border_ReSize = border_Color rgb_Border_ReSize = ini_rgb_Border_ReSize Exclude_fld_Name_ReSize = myFields Add_H_Each_Record_ReSize = False myDrawWidth = LineWidth 'make an array of the fields x_ReSize = Split(Exclude_fld_Name_ReSize, ",") ReDim Preserve sfld_Name_ReSize(UBound(x_ReSize)) ReDim Preserve sfld_Value_ReSize(UBound(x_ReSize)) ReDim Preserve sfld_Count_ReSize(UBound(x_ReSize)) '1 'do the Detail Lines for the remaining fields Call Detail_Sec_Max_Height '2 'now work on the special fields Lines For i_ReSize = 0 To UBound(x_ReSize) 'remove the ' , and the extra spaces from the Left and Right tmp_ReSize = RTrim(LTrim(Replace(x_ReSize(i_ReSize), "'", ""))) sfld_Name_ReSize(i_ReSize) = tmp_ReSize Call Scale_Box_Lines(tmp_ReSize) Next i_ReSize End Function Function Report_Open_Run(rpt_Name_ReSize_1) rpt_Name_ReSize = rpt_Name_ReSize_1 'Reset the variables from here Count_Pages_ReSize = 0 Erase sfld_Name_ReSize Erase sfld_Value_ReSize Erase sfld_Count_ReSize Detail_Calc_Height_ReSize = 0 End Function Function Report_Page_Run() 'make an array of the fields x_ReSize = Split(Exclude_fld_Name_ReSize, ",") 'now work on the special fields Lines For j_ReSize = 0 To UBound(x_ReSize) 'remove the ' , and the extra spaces from the Left and Right tmp_ReSize = RTrim(LTrim(Replace(x_ReSize(j_ReSize), "'", ""))) sfld_Name_ReSize(j_ReSize) = tmp_ReSize Set ctl_ReSize = Reports(rpt_Name_ReSize)(tmp_ReSize) If ini_rgb_Border_ReSize = 1 Then rgb_Border_ReSize = ctl_ReSize.ForeColor End If 'make it simple to understand L_ReSize = ctl_ReSize.Left W_ReSize = ctl_ReSize.Width T_ReSize = ctl_ReSize.Top 'H_ReSize = ctl_ReSize.Height 'we have to add the Sections/Fields ABOVE the Detail Section If Reports(rpt_Name_ReSize).Page = 1 Then H_ReSize = Detail_Calc_Height_ReSize + _ Reports(rpt_Name_ReSize).PageHeaderSection.Height + _ Reports(rpt_Name_ReSize).ReportHeader.Height Else H_ReSize = Detail_Calc_Height_ReSize + _ Reports(rpt_Name_ReSize).PageHeaderSection.Height End If Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize + H_ReSize)-(L_ReSize + W_ReSize, T_ReSize + H_ReSize), rgb_Border_ReSize 'Bottom Line Next j_ReSize Detail_Calc_Height_ReSize = 0 End Function Public Function Scale_Box_Lines(fld_Name As String) Set ctl_ReSize = Reports(rpt_Name_ReSize)(fld_Name) 'make it simple to understand L_ReSize = ctl_ReSize.Left W_ReSize = ctl_ReSize.Width T_ReSize = ctl_ReSize.Top H_ReSize = ctl_ReSize.Height If ini_rgb_Border_ReSize = 1 Then rgb_Border_ReSize = ctl_ReSize.ForeColor End If 'take the highst Height If fildMaxHeight_ReSize > H_ReSize Then H_ReSize = fildMaxHeight_ReSize End If If ctl_ReSize.Text <> sfld_Value_ReSize(i_ReSize) Then sfld_Value_ReSize(i_ReSize) = ctl_ReSize.Text sfld_Count_ReSize(i_ReSize) = 1 End If 'Box the cells 'Left and Right ctl_ReSize.BorderColor = vbWhite Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize, H_ReSize), rgb_Border_ReSize 'Left Line Reports(rpt_Name_ReSize).Line (L_ReSize + W_ReSize, T_ReSize)-(L_ReSize + W_ReSize, H_ReSize), rgb_Border_ReSize 'Right Line 'Top and Bottom If Reports(rpt_Name_ReSize).Page <> Count_Pages_ReSize Then 'first Count_Pages_ReSize = Count_Pages_ReSize + 1 Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize + W_ReSize, T_ReSize), rgb_Border_ReSize 'Top Line ElseIf sfld_Count_ReSize(i_ReSize) = 1 Then 'First Record Reports(rpt_Name_ReSize).Line (L_ReSize, T_ReSize)-(L_ReSize + W_ReSize, T_ReSize), rgb_Border_ReSize 'Top Line End If sfld_Count_ReSize(i_ReSize) = sfld_Count_ReSize(i_ReSize) + 1 End Function Public Function Detail_Sec_Max_Height() fildMaxHeight_ReSize = 0 'get the max Height For Each ctl_ReSize In Reports(rpt_Name_ReSize).Section(0).Controls If ctl_ReSize.Height > fildMaxHeight_ReSize Then fildMaxHeight_ReSize = ctl_ReSize.Height End If Next 'Draw lines around the fields For Each ctl_ReSize In Reports(rpt_Name_ReSize).Section(0).Controls If InStr(Exclude_fld_Name_ReSize, "'" & ctl_ReSize.Name & "'") = 0 Then Reports(rpt_Name_ReSize).DrawWidth = myDrawWidth Reports(rpt_Name_ReSize).Line (ctl_ReSize.Left, ctl_ReSize.Top)-Step(ctl_ReSize.Width, fildMaxHeight_ReSize), ctl_ReSize.ForeColor, B 'just add the Heighs of ONE Record If Add_H_Each_Record_ReSize = False Then Detail_Calc_Height_ReSize = Detail_Calc_Height_ReSize + fildMaxHeight_ReSize Add_H_Each_Record_ReSize = True End If End If Next End Function . 8. ما عدا هذا الجزء ، والذي يجب ان نضع فيه اسماء جميع الاقسام التي فوق "قسم التفصيل" ، والتي بها ارتفاع : . من هنا نعرف اسم هذه الاقسام : . وهذه نتائج بعض التقارير التي تم النجربة عليها : . . . . ولم اتوصل لطريقة لجعل الكلمات في منتصف الحقل عموديا ، هكذا: جعفر Report_BoxLine_07.accdb.zip

السلام عليكم اهداني اخي العزيز @حسونة حسين ملف اكسل يحتوي على جميع مواضيع منتدى اكسس وبروابط مباشرة اضعه بين ايديكم لا تنسونا من دعوات صالحات *********************** ( إضافات للموضوع - Moosak ) قمت بعمل تصميم بسيط لنموذج البحث وأضفته إلى الموضوع الرئيسي بعد أذن أستاذنا أبو خليل 🙂 بمجرد الكتابة تظهر النتائج .. لاستعراض الموضوع يتم الضغط على العنوان مباشرة النقر المزدوج على مربع البحث يعيد إظهار جميع النتائج 🙂 يمكن البحث بكلمات متفرقة في الجملة .. Search_Officena_Access.rar ********************************************** Access.rar

نعم ..رايت الموضوع ..والظاهر لدي مشاكل في الاوفيس والحاسوب

شكر وتقدير واحترام من القلب

السلام عليكم ورحمة الله وبركاتة ..... كل عام وحضراتكم بخير بعد اذن .. اخي .. كريم تفضل محمد.xls

بالمناسبة استاذ محمد ..الملف الثاني لا يفتح ..هل لديك نسخة مفتوحة ؟ بصراحة عجبتني الواجهة ااه عذرا ..صارلي فترة لم ادخل للموقع بسبب انشغالي ..الان وجدت موضوع ولدنا الحبيب موسى

اي كود يعطيك خطأ برجاء ارفق صوره من الخطأ للوصول للحل افضل 🌹

تخطر في بالي طريقة بسبب وجود الربط مثلما تفضل به استاذنا @ابوخليل جرب المرفق ..عسى ان ينفعك بطريقة او اخرى __مرسال الواتسأب(1).rar

برنامج دائن ومدين.zip

السلام عليكم ما شاء تصميم حلو لكن لو تسمح لي بملاحظتين عليه 1- بعد فتح البرنامج لا تظهر له ايقونة في شريط المهام 2- البرنامج لا يعتمد على المبادئ المحاسبية ، فالبرنامج للأسف أخل باهم قاعدة محاسبية والتي ليس لها استثناء وهي توازن المدين الدائن في سند القيد يعني عند الانتهاء من كتابة القيد يجب ان يكون مجموع المدين يساوي مجموع الدائن

تم الحل =SUM(IFERROR(VALUE(SUBSTITUTE(E8:G8,"إذن","")),""),0)

طبعا ..هو لايظهر خطأ في اوفيس 32 وانما في 64

سيتم تحويل حالة العرض الخاصة بكل صفحة بعد تنفيذ هذا الكود. إذا كانت الصفحة مرئية، فسيتم إخفاءها. وإذا كانت مخفية، فستصبح مرئية. يمكنك ضبط الكود حسب احتياجاتك Sub ShowHideSheets() Dim sht As Worksheet For Each sht In ThisWorkbook.Worksheets If sht.Visible = True Then sht.Visible = False Else sht.Visible = True End If Next sht End Sub كود فورم 1 به شاشة دخول للورك بوك Private Sub CommandButton1_Click() ' تحقق من صحة اسم المستخدم وكلمة المرور If TextBox1.Value = "اسم المستخدم الصحيح" And TextBox2.Value = "كلمة المرور الصحيحة" Then UserForm2.Show ' اعرض UserForm2 إذا كانت بيانات الدخول صحيحة Else MsgBox "اسم المستخدم أو كلمة المرور غير صحيحة" ' أظهر رسالة خطأ إذا كانت بيانات الدخول غير صحيحة End If End Sub

منطقيا لا يمكن لان جدول MultiNamesTable يحتوي على حقل مرتبط بالجدول GroupsTable وغير موجود في جدول main1115 الحل ان تدمج جدول GroupsTable مع main1115 باستعلام ولن تتمكن لانه يجب عليك تنشء حقل مرتبط بينهما مشكلتك : انك تريد ادراج سجلات جديدة في جدول MultiNamesTable من غير حقل IDMain لو حذفت العلاقة بين الجدولين ستتمكن من الإلحاق ولكن لن يمكنك الاطلاع على البيانات من خلال جدول GroupsTable الرئيس وسيبقى حقل IDMain خاليا او ستتمكن لو ان العلاقة بين الجدولين يكون جدول MultiNamesTable هو الرأس وحقل IDMain ترقيم تلقائي

جزاك الله خيراً أستاذى @Moosak تمام بارك الله فيك تم تغيير الرسالة باسم كل شخص

بارك الله فيك استاذنا موسي روووعه زادك الله علما ما شاء الله عليك هل من الممكن استاذي تطويره بحيث أن يكون يشتغل بدون تنصيب تطبيق الواتساب تحياتي يالغالي

بارك الله لك استاذ محمد عمل متقن مرتب جزاك الله عنا كل الخير . رمضان كريم وكل عام وأنتم بخير .

السلام عليكم و رحمة الله اكتب هذا فى حدث الفورم Private Sub UserForm_Initialize() Me.TextBox1 = Format(Date, "yyyy/mm/dd") End Sub

اساتذتي الافاضل حصلت عندي برنامج جميل للاستاذ Nart Lebzo . NA_BirthdayReminder.accdb

Suppose the cells are B1 & B2 for the year and the month, try the following code in worksheet change event Private Sub Worksheet_Change(ByVal Target As Range) Const FirstRow As Long = 4, FirstColumn As Long = 3, numColumns As Long = 366, sColTarget As String = "C:ND" Dim results(1 To 2, 1 To numColumns), yearValue As Long, currentDate As Date, lastDate As Date, i As Long, selectedMonth As Long, col As Long If Target.Address = "$B$1" Then If Target.Value = Empty Then Columns(sColTarget).Rows(FirstRow & ":" & FirstRow + 1).ClearContents: GoTo Skipper On Error Resume Next yearValue = CInt(Target.Value) On Error GoTo 0 If IsDate("01/01/" & yearValue) Then currentDate = DateSerial(yearValue, 1, 1) lastDate = DateSerial(yearValue + 1, 1, 1) - 1 i = 0 While currentDate <= lastDate i = i + 1 results(1, i) = Format(currentDate, "ddd") results(2, i) = Format(currentDate, "yyyy-mm-dd") currentDate = currentDate + 1 Wend Application.EnableEvents = False Application.ScreenUpdating = False Range(Cells(FirstRow, FirstColumn), Cells(FirstRow + 1, FirstColumn + i - 1)).Value = results Application.ScreenUpdating = True Application.EnableEvents = True Else MsgBox "Please Enter Valid Year", vbExclamation End If ElseIf Target.Address = "$B$2" Then If Target.Value = Empty Then GoTo Skipper On Error Resume Next selectedMonth = Left(Target.Value, InStr(Target.Value, ".") - 1) On Error GoTo 0 If selectedMonth <> 0 Then Application.EnableEvents = False Application.ScreenUpdating = False Columns(sColTarget).Hidden = True For col = FirstColumn To numColumns + (FirstColumn - 1) If IsDate(Cells(FirstRow + 1, col).Value) Then If Month(Cells(FirstRow + 1, col).Value) = selectedMonth Then Cells(FirstRow + 1, col).EntireColumn.Hidden = False End If Next col Application.ScreenUpdating = True Application.EnableEvents = True End If End If Exit Sub Skipper: Application.EnableEvents = False Columns(sColTarget).Hidden = False Application.EnableEvents = True End Sub

مشاركة خفيفة مع العم @ابوخليل 🙂 طريقة الحصول على تاريخ أول يوم وآخر يوم في الأسبوع بأسهل طريقة بناءا على تاريخ اليوم ()Date : startWeek = DateAdd("d", -(Weekday(Date) - 1), Date) endWeek = DateAdd("d", 6, DateAdd("d", -(Weekday(Date) - 1), Date)) ولمعرفة أول يوم وآخر يوم في الأسبوع لتاريخ معين (غير تاريخ اليوم) .. قم باستبدال Date بالتاريخ الذي تريده .

You can use this formula directly =SUM($F$3:F3)>الرئيسي!$D$3

جزاكما الله خير الجزاء اخوتي واساتذتي ربي يرحم امواتكم ويحفظ احبابكم

والله نجحت فى تعديل على الكود ليتماشى مع ملفك ويكون شيت الورد مفتوح الترحيل من الاكسيل الى الورد.rar

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة برنامج محاسبة لادارة مكتبة تم ارفاق المشاركه من الفاضل _ أ / طلعت محمد حسن و لا تنسونا من صالح الدعاء تحياتى مكتبةsama.rar

اخواني الكرام بعون الله تعالى تم الانتهاء من انجاز محفظة الاكواد وهي عبارة عن تجميع الاكواد التي قدمها الاخوة الكرام في موضوع الاكواد المنفصلة بارك الله فيهم و المحفظة من ابداع استاذنا الكريم خبور خير بارك الله و وفقه الى الخير وهي النسخة الاولى وستتبعها نسخ اخرى ان شاء الله ,ارجوا ان يستفيد منها اخواني الكرام اعضاء هذا المنتدى الحبيب محفظة اكواد___النسخة1.rar

السلام عليكم أخواني الأعزاء إليكم المرفق أرجو أن يلبي إحتياجاتكم وأن تجدوا به الشرح الكافي أعتذر عن عدم تنسيق الشرح ولكن أرجو قراءة كل الملاحظات بالورقتين وفقنا الله وإياكم لما فيه الخير ______________3.rar