كل الانشطه

علما بان اخينا الفاضل شايب سبق ان اشار الى موضوع مشابه في هذة المشاركة ⬇️ الشايب

أهلاً بك معنا في منتدانا الكبير ، وأتمنى أن تجد الفائدة التي ترجوها . وما ذكرته لك حتى لا يتعرض موضوعك للإغلاق أخي @صالح الصالحي

حاضر سأقوم بإعادة ارسالة مع تعديل ماذكرت واعذرني فأنا قليل خبرة في المنتدى والاكسس

المطلوب اذا كان الرقم اكبر من او يساوى 1 يكتب برنامج علاجى من الخلية الاولى او اذا كان الرقم 10 فى الخلية الثانية يكتب راسب

ارجو أخي الكريم @صالح الصالحي ان تقوم بالغاء افضل إجابة ، واستخدامها لحين ان تجد الإجابة الصحيحة أياً كان مقدمها ، هذا أولاً ثانياً ، التزاماً بقواعد المنتدى ادراج بعض البيانات التي ترغب بانتاج البحث والتقارير عنها ، وليس ارفاق ملف فارغ وكأنك تريد من ممن يقدم المساعدة أن يملأه ثالثاً ، للوصول لحلول لمشكلتك :- لا تستخدم أسماء عربية في مسميات الحقول . لا تستعمل المسافات بين الأسماء . لا تستعمل اسماء حقول محجوزة للبرنامج مثل ( Name,Date,To,From ..... إلخ ) لا تستعمل رموز ( #، @،$،& .... إلخ ) في مسميات الحقول . لا تستعمل الأرقام في أسماء حقول الجداول أو تبدأ بها . قواعد المشاركة بمنتدي أوفيسنا

شكرا لك وهذا هو الملف المواقف.zip

السلام عليكم اخونا الكبير شايب يعتقد ان طريقة جعفر للعمل على النواتين طريقة شاملة ولكن في مثل هذه الحالة التي واجهت الاستاذ سلوم بعد اضافة Ptrsafe فقط يكفي ان نقوم بتغير اي متغير رقمي من long الى LongLong او الى LongPtr وسوف يعمل البرنامج ويختصر عدة اسطر من الكود اخير LongPtr ليس نوع بيانات حقيقي وانما يتوافق مع الاصدرين 32 و 64 بحيث يتحول الى long مع 32 و longlong مع 64 ايضاح اخير يمكن تقيد فتح النموذج الاخير بحيث لا يمكن فتحه الا من خلال زر الامر بعد كتابة الرمز الصحيح ولكن نكتفي بهذه المشاركة اخونا الشايب رقم سري.accdb

جزاك الله خير على الهدية أخونا الفاضل @عبد اللطيف سلوم ، ولمشاركتك فكرة أستاذنا @ابو جودي ( رغم غيابه عنا في الفترة الأخيرة ) . إلا أني دائماً أتوجه إلى أن تكون بداية الأسبوع عندي يوم السبت وليس الإفتراضي حسب الكمبيوتر يوم الأحد ، فهذا تعديل لا يلمس شيء في هديتك سوى أنه يجعل احتساب الأسبوع يبدأ من يوم السبت لا الأحد . Private Sub salloum_AfterUpdate() Me.x1 = Me.salloum.Column(1) Select Case Me.salloum.Column(0) Case "1" Me.n1 = DateSerial(Year(Date), 1, 1) Me.n2 = DateSerial(Year(Date), 12, 31) Case "2" Me.n1 = DateSerial(Year(Date), Month(Date), 1) Me.n2 = DateSerial(Year(Date), Month(Date) + 1, 0) Case "3" Me.n1 = DateAdd("d", -Weekday(Date, vbSaturday) + 1, Date) Me.n2 = DateAdd("d", 6, Me.n1) Case "4" Me.n1 = DateSerial(Year(Date) - 1, 1, 1) Me.n2 = DateSerial(Year(Date) - 1, 12, 31) Case "5" Me.n1 = DateSerial(Year(Date), Month(Date) - 1, 1) Me.n2 = DateSerial(Year(Date) - 1, 12, 31) Case "6" Me.n1 = DateAdd("d", -Weekday(Date, vbSaturday) + 1, Date) - 7 Me.n2 = DateAdd("d", 6, Me.n1) Case "7" Me.n1 = Null Me.n2 = Null End Select End Sub

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

Foksh كتر اف خيرك ...تمام بالظيط هوا ده اللى انا عايزه ..متشكر جدااااااا kkhalifa1960 اخى الكريم ...متشكر جدا لاهنمامك بس الحمد لله لقيت الحل ..وكتر الف خير

سافعل ذلك لكن المهم عندي هو الكاميرا صراحة سأجرب وأخبرك ان شاء الله

يتشرف #مركز_الرؤية_الاستراتيجية_للتدريب #Strategic_Vision_Training_Center لدعوة سيادتكم للأنضمام الي الدورات التدريبية التالية,,,,, دورات تسويق مبيعات خدمة العملاء الاستثمار العقاري وفن البيع والتسويق مقدمة إن أهمية الدورات التدريبية ليست قاصرة فقط على الحياة المهنية كما يظن أغلبنا .. ولكن الدورات التدريبية تهدف إلى نقل المعرفة والخبرات العملية التى تثقل مهارات الأفراد وتعزز الثقة بالنفس لديهم مما يساهم في إعداد الكوادر مما يعود بدوره على تطوير وتقدم المؤسسات .لذا يهدف مركز الرؤية الاستراتيجية للتدريب إلى تعزيز مهارات وخبرات الافراد من خلال أقوى البرامج التدريبة لنواكب كل تطور في سوق العمل . #دورات #تسويق #مبيعات #خدمة_عملاء دورة إستراتيجيات وإعداد الخطط التسويقية وتنشيط المبيعات دورة الإدارة الحديثة للتسويق والاستثمار العقاري دورة التسويق الإبداعي نظرية GUERILLA MARKETING دورة التسويق الرقمي المتقدم دورة القيادة المتقدمة لمديرى المبيعات وادارة الابداع والتخطيط دورة المهارات المتكاملة في إدارة العلاقات العامة وفن التعامل مع كبار الشخصيات (VIP) دورة تخطيط وتنفيذ الحملات الاعلامية دورة تسويق التجارة الإلكترونية دورة حملة التسويق للعلامات التجارية دورة شهادة SEO دورة مدير المبيعات الفعال دورة مهارات البيع والتسويق الحديثة دورة مهارات التسويق والمبيعات للمحترفين في إدارة الأعمال دورة خدمة العملاء الاحترافية في الرعاية الصحية كما يتم تنفيذ #الدورات_التدريبية فى #المجالات_التدريبية الاتية : #الدورات الهندسية ) الكهربائية - الميكانيكية والسيارات - الهندسة المدنية والمشاريع والطرق - هندسة المساحة - الصيانة - البترول والجولوجيا( دورات البيئة وصحة وسلامة الغذاء دورات الامن الصناعي والسلامة والصحة المهنية دورات الامن دورات القانون والعقود دورات الجودة والأنتاج دورات القيادة والادارة دورات العلاقات العامة والدولية والاعلام دورات السكرتارية وادارة المكاتب دورات التسويق والمبيعات وخدمة العملاء دورات الموارد البشرية دورات المحاسبة والمالية دورات البنوك والمصارف دورات المشتريات والمخازن دورات النقل و اللوجستيات وادارة سلاسل التوريد أماكن الانعقاد ( #دبي #اسطنبول #كوالالمبور #المغرب #السعودية #شرم_الشيخ #القاهرة #الأسكندرية ) للتسجيل او لطلب العرض الفنى والمالى يرجى الاتصال او ارسال بريد الاكترونى Islam Ali 00201553134200 WhatsApp: +201555728000 Islam@svtcenter.com www.svtcenter.com Facebook https://www.facebook.com/profile.php?id=100086139318374 Twitter https://twitter.com/StrategicVisio7 Linkedin https://www.linkedin.com/company/strategic-vision-training-center/ Instagram https://www.instagram.com/strategicvisiontrainingcenter WIX https://eslam-training.wixsite.com/training Website https://www.svtcenter.com/ar/Home

ادن اخي حاول التركيز معي سنشتغل على شيت الفواتير لترحيل البيانات اليه مع مراعات عدم تكرار الفواتير في حالة وجودها مسبقا اعتمادا على رقم الاسبوع الدي سيتم اظافته تلقائيا استنادا الى اخر تاريخ للفواتير المرحلة ويوم بداية الاسبوع الافتراضي بالنسبة لك هو يوم (الجمعة) مع اخد في عين الاعتبار تنسيق وشكل البيانات بعد كل ترحيل المطلوب مسبقا الاكواد طويلة نوعا ما بسبب التنسيقات المطلوبة لاكنها سريعة في التنفيد 😉 كود الترحيل Sub Copy_data() Dim StDate$, EnDate$, iCnt&, fRow&, Invoice$ Dim rngMain As Range, rngCount, LR&, x& Dim arrMain As Variant, arrCount() As Variant, sht As Worksheet Dim Cpt As Range: Dim FndRng As Range: Dim MyRng As Range: Dim c As Range Dim week As Date: Dim i As Integer: Dim Clé As Range: Dim xDate As Range Dim d As Integer: Dim FindWeek As Range: Dim OneRng As Range: Dim n As Range Dim desWS As Worksheet: Set desWS = ActiveSheet Dim srcWS As Worksheet: Set srcWS = Sheets("فواتير الاسبوع") Dim WS As Worksheet: Set WS = sheet1 Set Clé = desWS.[BU331]: Set MyRng = desWS.[BW330:CK372] StDate = desWS.[CA328]: EnDate = desWS.[CE328] week = desWS.[DC330].Value d = 15 ' اليوم الافتراضي لبداية الأسبوع (الجمعة) st = Application.WeekNum(week, d) On Error Resume Next Application.ScreenUpdating = False If Len(desWS.[CA328].Value) = 0 Then Exit Sub Set FindWeek = srcWS.Rows(3).Find(what:=st, LookIn:=xlValues, _ LookAt:=xlWhole) If Not FindWeek Is Nothing Then If MsgBox(" تم ترحيل فواتير الأسبوع" & " " & st & " :" & "مسبقا" & Chr(10) & Chr(10) _ & " معاينة الفاتورة" & "؟", vbYesNo, "تم إلغاء الإجراء") = vbYes Then Dim cel As Range Invoice = st.Value For Each c In srcWS.Rows(3) If c.Value = Invoice Then Set cel = srcWS.Range(FindWeek.Address) Application.GoTo Reference:=cel ActiveWindow.ScrollColumn = cel.Column - 13: ActiveWindow.ScrollRow = cel.Row - 2 Exit Sub Next End If Exit Sub Else With Application .ScreenUpdating = False .DisplayAlerts = False WS.Cells.Clear For i = StDate To EnDate: Clé.Value = i MyRng.Copy If WorksheetFunction.CountA(WS.Cells) = 0 Then LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 1 Else LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 3 End If With WS.Range("A" & LR) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With Next i fRow = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape For i = 1 To fRow Step 45 j = j + 1 WS.HPageBreaks.Add WS.Range("A" & i) Next i WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j Set sht = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Range("A1:O" & fRow + 1).Copy With sht.Range("b" & Rows.Count).End(xlUp)(2) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Irow = sht.Range("A:P").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 Set rngMain = sht.Range("A2:P" & Irow) Set rngCount = sht.[A3]: arrMain = rngMain.Value ReDim arrCount(1 To UBound(arrMain, 1), 1 To 1) For x = 1 To UBound(arrMain) If arrMain(x, 3) = "حامض" Then iCnt = iCnt + 1 arrCount(x - 5, 1) = iCnt End If Next x With rngCount.Resize(UBound(arrMain), 1) .Value = arrCount: .Font.Color = RGB(255, 0, 0): .Font.Bold = True: .Font.Size = 20 End With If WorksheetFunction.CountA(srcWS.Cells) = 0 Then Set OneRng = srcWS.Rows("1:4") For Each c In OneRng c.HorizontalAlignment = xlGeneral: c.VerticalAlignment = xlCenter: c.HorizontalAlignment = xlCenter c.RowHeight = 22: c.Font.Bold = True:: c.Font.Size = 14 Next c lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column ' + 1 Else lCol = srcWS.Cells(10, srcWS.Columns.Count).End(xlToLeft).Column + 3 End If Dim Col_Widths As Range Set Col_Widths = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9)) Set Col_Border = Union(srcWS.Cells(lCol + 3), srcWS.Cells(lCol + 5), srcWS.Cells(5, lCol + 9), srcWS.Cells(1, lCol + 4)) rngMain.Copy With srcWS.Cells(5, lCol) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False Col_Widths.ColumnWidth = 18 j = Array(StDate, "", "", "", EnDate) With srcWS.Cells(1, lCol + 4).Offset(1).Resize(, 5) .Value = j: .Interior.Color = vbYellow: .Font.Color = RGB(255, 0, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) With srcWS.Cells(3, lCol + 12) .Value = "الأسبوع رقم :": .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) With srcWS.Cells(3, lCol + 13) .Value = st: .Font.Color = RGB(255, 0, 0): .Interior.Color = vbYellow .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) End With End With End With End With srcWS.Activate: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1: [B6].Select: ActiveWindow.Zoom = 95 a = Array("فواتير الأسبوع من", " ", CDate(desWS.[CV330]), " ", "إلى", " ", CDate(desWS.[DC330])) With srcWS.Cells(2, lCol + 3).Offset(1).Resize(, 7) .Value = a: .Interior.Color = RGB(255, 255, 0) .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium, Color:=RGB(0, 0, 0) End With For Each xDate In srcWS.Range("D3", srcWS.Cells(3, Columns.Count).End(xlToLeft)) If IsDate(xDate.Value) Then xDate.NumberFormat = "yyyy-mm-dd" Next xDate sht.Delete MsgBox " تم ترحيل فواتير الأسبوع رقم :" & " " & st & " " & "بنجاح", vbInformation, "معلومات" desWS.Activate On Error GoTo 0 .DisplayAlerts = True .ScreenUpdating = True End With End If End Sub اما بالنسبة لكود حفظ الفواتير بصيغة PDF تم فصله وتعديله لتتمكن من حفظ او طباعة اي فواتير مرحلة مسبقا بعد استدعائها بشرط رقم الاسبوع بالشكل المطلوب مسبقا (كل فاتورة في ورقة مستقلة) Sub Choose_invoice_Print() Dim rng As Range, c As Range, Invoice As Range Dim Cpt&, Path As String, sFile As String Dim desWS As Worksheet: Set desWS = ActiveSheet Dim srcWS As Worksheet: Set srcWS = Sheets("فواتير الاسبوع"): Set WS = sheet1 On Error Resume Next If WorksheetFunction.CountA(srcWS.Cells) = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub Choose_invoice = InputBox(" المرجوا ادخال رقم الأسبوع " & "؟", " : حفظ وطباعة الفواتير الأسبوعية") If Choose_invoice = "" Then: Exit Sub FolderName = "Raed": Path = ThisWorkbook.Path & "\" & FolderName Set FindWeek = srcWS.Rows(3).Find(what:=Choose_invoice, LookIn:=xlValues, _ LookAt:=xlWhole) If Not FindWeek Is Nothing Then sFile = "الفواتير من" & " " & Format(FindWeek.Offset(0, -8).Text, "dd-mm-yyyy") _ & " " & "إلى" & " " & Format(FindWeek.Offset(0, -4).Text, "dd-mm-yyyy") Msg = MsgBox("؟" & " " & "PDF " & ":" & " حفظ فواتير الأسبوع" & " / " & FindWeek & " بصيغة", vbYesNo, sFile) If Msg <> vbYes Then Exit Sub Invoice = Choose_invoice.Value Application.ScreenUpdating = False For Each c In srcWS.Rows(3) If c.Value = Invoice Then Application.GoTo Reference:=srcWS.Range(FindWeek.Address) WS.Visible = xlSheetVisible: WS.Cells.Clear Cpt = ActiveCell.Column - 3 Irow = srcWS.Cells(srcWS.Rows.Count, Cpt).End(xlUp).Row Set rng = Range(ActiveCell.Offset(3, -12), ActiveCell.Offset(Irow - 2, 2)) rng.Copy With WS.Range("A" & Rows.Count).End(xlUp)(2) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Next f = WS.Range("A:O").Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row WS.ResetAllPageBreaks: WS.PageSetup.Zoom = False WS.PageSetup.PrintArea = "A:O": WS.PageSetup.Orientation = xlLandscape For i = 1 To f Step 45 j = j + 1 WS.HPageBreaks.Add WS.Range("A" & i) Next i WS.PageSetup.FitToPagesWide = 1: WS.PageSetup.FitToPagesTall = j If Dir(Path, vbDirectory) = "" Then MkDir Path nf = Dir(Path & "\" & sFile & "*") n = 0 Do While nf <> "" n = n + 1 nf = Dir Loop WS.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=Path & "\" & sFile & " (" & n + 1 & ")" & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' تفعيل الطباعة 'WS.PrintOut WS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Else MsgBox "رقم الأسبوع غير موجود على قاعدة البيانات", vbExclamation, "تم إلغاء الإجراء" End If On Error GoTo 0 desWS.Activate End Sub Book معدل 2.xls

طيب كفكرة ، جرب هذا المرفق وخذ لقطة للشاشة وادرجها هنا لرؤية النتيجة :- اختيار ماسح ضوئي.accdb

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

يبدو ان المشكلة لدي في جهاز الحاسب

السلام عليكم الاخوة الاعزاء فى الملف المرفق اريد دمج الدالتين IF فى خلية واحدة بنفس الشروط ادماج المعادلتين.xlsx

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

اختلط علي الأمر هههههههه بسيطة دي يا دكتور .. احنا نحجز متغير من نوع Date وليكن اسمه التاريخ السابق ( PreviousDate ) ، ونحدد قيمته بناقص يوم للتاريخ الذي في مربع النص Text15 ، ثم نحدد قيمة مربع النص Text17 بتغيير بسيط ، ليصبح الكود كالآتي :- Dim PreviousDate As Date PreviousDate = DateAdd("d", -1, Me.Text15.Value) Me.Text17.Value = Nz(DLookup("rased", "T1", "mastedate = #" & Format(PreviousDate, "mm/dd/yyyy") & "#"), 0)

اهلا باستاذى الغالى فى الحقيقة لقد قمت بعمل ماقمت حضرتك بعمله وكتبت هذا الكود بالصبط انا اريد ان يظهر الرصيد الذى قبله بمعنى اذا دخلت التاريخ 2024/05/02 فيظهر الرصيد الذى يسبقه وهو 17 اذا دخلت التاريخ 2024/05/01 فيظهر الرصيد الذى يسبقه وهو 5 اذا دخلت التاريخ 2024/04/30 فيظهر الرصيد الذى يسبقه وهو 8 جزاك الله كل خير

الشكر لله اخي الحمد لله الذي بنعمته تتم الصالحات

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

صديقي الدكتور @الحلبي ، أعلم جيداً انك قد توجهت للدالة Dlookup وأنك لم تحصل ما تطلبه والسبب هو باعتقادي أنه بالتاريخ المطلوب الذي حددته سيقرأ اكسيس التاريخ على انه تنسيق dd/mm/yyyy ولكنه في الواقع بهذا التنسيق mm/dd/yyyy ، لذا تفضل بتجربة هذا السطر في حدث بعد التحديث لمربع نص التاريخ Text15 :- Me.Text17.Value = Nz(DLookup("rased", "T1", "mastedate = #" & Format(Me.Text15.Value, "mm/dd/yyyy") & "#"), 0) الرصيد.accdb جرب وأخبرني بالنتيجة

السلام عليكم مرفق مثال اريد فيه عندما ادخل التاريخ فى حقل التاريخ يظهر الرصيد السابق مباشرا فى حقل الرصيد بمعنى : اذا دخلت فى حقل التاريخ 02/05/2024 يظهر الرصيد السابق فى حقل التاريخ وهو 17 جزاكم الله خير الرصيد.rar