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

السادة اعضاء المنتدى الأفاضل تم تزويد الملف بالاكواد ويعمل الحمد لله بطريقة جيدة أضعه هنا اذا اراد احد الاستفادة منه Pension2023.xlsm

Hello. Try the following code that is not exactly as you need but give it a try All the bills will be exported to only one pdf to Desktop instead of creating a pdf for each bill Sub Export_All_Bills_To_One_PDF() Dim bill, wb As Workbook, wsData As Worksheet, wsBill As Worksheet, wsCounter As Worksheet, shp As Shape, lr As Long, ls As Long, r As Long, m As Long, n As Long Application.ScreenUpdating = False With ThisWorkbook Set wsData = .Worksheets(1): Set wsBill = .Worksheets(2): Set wsCounter = .Worksheets(3) End With lr = wsCounter.Cells(Rows.Count, "A").End(xlUp).Row ls = wsData.Cells(Rows.Count, "B").End(xlUp).Row Set wb = Workbooks.Add(xlWBATWorksheet) For r = 2 To lr wsBill.Range("D1").Value = wsCounter.Cells(r, 1).Value bill = wsBill.Range("A2").Value wsBill.Range("A6:B30").ClearContents: n = 6 For m = 3 To ls If wsData.Cells(m, "B").Value = bill Then wsBill.Range("A" & n).Resize(, 2).Value = wsData.Range("C" & m).Resize(, 2).Value n = n + 1 End If Next m wsBill.Copy After:=wb.Worksheets(wb.Worksheets.Count) With ActiveSheet .Range("A2").Value = .Range("A2").Value .Range("D1").ClearContents For Each shp In .Shapes shp.Delete Next shp End With Next r Application.DisplayAlerts = False wb.Worksheets(1).Delete Application.DisplayAlerts = True wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Environ("USERPROFILE") & "\Desktop\" & "All_Bills.pdf", OpenAfterPublish:=True wb.Close SaveChanges:=False Application.ScreenUpdating = True End Sub

يحفظكم الرحمن الرحيم

Don't forget to remove all the codes in your file before executing the code I posted

لإنشاء مفتاح اساسي استخدم الكود التالي DoCmd.RunSQL "ALTER TABLE [mowadfen_check] ADD CONSTRAINT PK_Person PRIMARY KEY ([الرقمالوظيفي], [التاريخ]) لإلغاء المفتاح الأساسي استخدم الكود التالي DoCmd.RunSQL "ALTER TABLE [mowadfen_check] DROP CONSTRAINT PK_Person"

استخدمت لك كود استاذ ابو احمد اما كود استاذ محمد عصام فيحتاج الى فاكتور في النموذج aaa.rar

هذا ملف ادعو الله ان يجزي بالخير كل من ساعد علي ظهوره برنامج بسيط لشئون العاملين رقم الدخول 1111 شئون+العاملين+2016.rar

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

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

السلام عليكم ممكن لمساعدة في برنامج اشتركات انترنت شهرية يتم التجديد كل شهر على الاكسس

نعم ممكن ان تقوم بتغييره كما تريد مع تغييره داخل الكود

بارك الله فيك اخي ونفع بك

تفضل Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Q2")) Is Nothing Then 'خلية التنفيد Select Case Range("Q2") 'اسم الماكرو __________________تعريف الماكرو Case "Code1": بحث_واستبدل Case "Code2": معاينة_مع_الطباعة Case "Code3": نسخة_طبق_الأصل_من_الشيت Case "Code4": saad5 Case "Code5": saad6 Case "Code6": saad7 End Select End If End Sub تجربة V1.xlsm

تفضل جرب Sub filtre() Dim sh As Worksheet, sh2 As Worksheet Dim lastRow As Long, lrow As Long, Article As Range Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("c2") Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("A" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجوا ادخال الصنف": Exit Sub Set Article = sh2.Range("D:D").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:E" & lrow).ClearContents sh2.Range("D1").AutoFilter Field:=4, Criteria1:="=" & Rng sh2.Range("A1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("B4").PasteSpecial xlPasteValues sh2.Range("B2:B" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh2.Range("D2:F" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("C4").PasteSpecial xlPasteValues End With Else m = MsgBox("الصنف " & " " & ST & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True End Sub mywork v2.xlsm

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

تفضل أخي المرفق بعد التعديل . checkbox-1.accdb

هذا الموضوع ذكرني بموضوع شاركت فيه وصاحبه يعاني وسيستمر يعاني إن لم يسمع الكلام ويستفيد من نصائح الخبراء: إذا كان الموضوع له علاقة بالوقت فالأمر يختلف ولكن إذا كان الأمر له علاقة بالتواريخ فلننتبه إلى التالي والفرق بينها: في المدد هناك: - نهاية المدة (آخر يوم في المدة) End Date أو Last Date أو To Date - تاريخ الإنتهاء أو تاريخ الإستئناف أو تاريخ مباشرة العمل بعد انقطاع (أول يوم بعد انتهاء مدة إجازة مثلا) Expiry Date أو Resume Date فشهر يناير يبدأ من 01/01 وينتهي في 31/01 وليس 01/02 ومدته ستكون 31 يوم والأسبوع يبدأ بالأحد وينتهي بالسبت وليس الأحد ومدته ستكون 7 أيام فلنحسن المسمى لنحسن الحساب، لا أريد أن أتكلم عن خبراتي حتى لا تتعرفوا على شخصيتي الأصل 🙂 لو سأحسب الغياب لموظف غاب يوم 5 يناير سأسجله في جدول يحتوي على حقلين مثلا سيكون غيابه من 05/01 إلى 05/01. تحبون تعقدونها على الرجال عقدوها كما تعقد صاحبنا في الموضوع المشار إليه أعلاه 🙂 . ولا أستبعد من تواصل معه عبر الرسائل وقدم له نصيحة خاطئة.

تفضل جرب اخي لاكن حاول دائما عدم طلب اكثر من طلب في موضوع واحد لكي يستطيع الاساتدة مساعدتك. لا احد لديه الوقت الكافي لاتمام كل الطلبات ...عند الانتهاء من ترحيل البيانات بنجاح قم بفتح وضوع جديد. وسوف نكون سعداء بمساعدتك. بالتوفيق.......... Sub Transfer() ' ترحيل Dim rng As Range, line As Range, cl As Range Dim C As Long, lastrow As Long Dim msg As VbMsgBoxResult Dim WSdata As Worksheet: Set WSdata = Worksheets("Items") Dim WSdest As Worksheet: Set WSdest = Worksheets("Orders") lastrow = WSdest.Cells(WSdest.Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False 'التحقق من وجود بيانات على الخلايا التالية WSdata.Activate Arr = Array([F4], [F6], [H6], [H9], [H9], [F13], [H13], [J13]) For i = 0 To 7 If Arr(i) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(i).Offset(0, -1), vbExclamation, "إنتباه" Arr(i).Select Exit Sub End If Next 'التحقق من وجود اسم العميل مسبقا لمنع التكرار If Application.WorksheetFunction.CountIf(WSdest.Range("D:D"), WSdata.Range("F4").Value) > 0 Then MsgBox "إسم العميل مضاف مسبقا", vbExclamation, "إنتباه" Exit Sub End If ''''''''''''''''''''''''''''''''''''''''''''''''''''''' msg = MsgBox("ترحيل البيانات ؟ ", vbYesNo + vbQuestion + vbDefaultButton2, "") If msg = vbNo Then Exit Sub Else End If Set rng = WSdata.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20,H20") C = 3 For Each cl In rng cl.Copy WSdest.Cells(lastrow + 1, C).PasteSpecial xlPasteValues C = C + 1 Next cl 'تسلسل البيانات With WSdest.Range("B7:B" & lastrow + 1) .Formula = "=Row() - 6" .Value = .Value End With Application.CutCopyMode = False 'حدف الصفوف الفارغة On Error Resume Next Set line = Range("Orders[[إسم العميل]]").SpecialCells(xlCellTypeBlanks) If Not line Is Nothing Then line.Delete Shift:=xlUp End If On Error GoTo 0 'افراغ الخلايا WSdata.Range("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,F20,H20") = Empty Application.ScreenUpdating = True m = MsgBox("تم ترحيل البيانات بنجاح", 64, "تأكيد") End Sub

يحفظكم الرحمن الرحيم

بعد اذن السادة الاعضاء ، تفضل ممكن تساعدك هذه الإجابة ان شاء الله لتفريغ الفورم بعد كل عملية بحث أو ترحيل، يمكنك استخدام الكود التالي في الحدث المناسب في فورمك (مثل زر "موافق" أو "ترحيل"): Private Sub ClearForm() ' تفريغ قيم العناصر في الفورم TextBox1.Value = "" ComboBox1.Value = "" ListBox1.Clear ' تنظيف أي بيانات أخرى في الفورم حسب الحاجة ' تعيين تركيبة أو قيم افتراضية أخرى لعناصر الفورم ' إعادة تحميل أو تحديث أي بيانات أو عرض آخر حسب الحاجة End Sub يمكنك استدعاء الدالة ClearForm بعد اكتمال عملية البحث أو الترحيل لتفريغ الفورم من المعلومات الموجودة واستعادتها إلى حالتها الأولية. قم بتعديل الكود بما يتناسب مع عناصر الفورم الخاصة بك وأي تعديلات أخرى ترغب في إجرائه

أحسنت استاذ أشرف بارك الله فيك وزادك الله من فضله

استاذى الجليل اليكم التطبيق Ceiling function (2).mdb

وعليكم السلام-انتبه من فضلك لا يمكن تقديم المساعدة لأحد بدون رفع ملف مدعوم بشرح كافى عن المطلوب فلا يمكن العمل على التخمين وتجنباً لإهدار وقت كل من يطلع على مشاركتك دون جدوى أو أهمية !!

للأسف الملف المضغوط لم يفتح معي لكن تم تطبيق الكود على الملف في ردي السابق

Try Sub Test() Dim ws As Worksheet, sh As Worksheet, tbl As ListObject, lr As Long, i As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets("Items"): Set sh = .Worksheets("Orders") End With Set tbl = sh.ListObjects(1) lr = tbl.Range.Rows.Count + tbl.Range.Row - 1 Do While sh.Cells(lr, "C").Value = Empty lr = lr - 1 Loop lr = lr + 1 Dim a(1 To 16), e For Each e In Split("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20", ",") i = i + 1 a(i) = ws.Range(e).Value Next e sh.Range("C" & lr).Resize(, 16).Value = a Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

السلام عليكم ورحمة الله وبركاتة ....................................... كل عام وحضراتكم بخير وصحه وعافية رفعت هذا البرنامج للفائدة برنامج محاسبة العمال بالدقيقة 🕒 البرنامج سهل الاستخدام يتم اصافة عميل -حذف عميل .. كما يوجد شيت داخل البرنامج لشرح استخدامة صورة توضيح الاستتخدام هنا الصفحة الرئسية هنا الصفحة المنسوخ منها صفحة العميل الجديد وهذة صفحة شرح كيفية استخدام البرنامج البرنامج في المرفقات برنامج محاسبة العامل بالساعة-1-6-2023-.xlsb

وعليكم السلام هدية قيمة ومقبولة بارك الله فيك وأكرمك الله

تم دمج الموضوعين تفضل AVIrep2.rar

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

أهلا بك أياد.. وشكرا على التقييم لكن مازال هناك مسائل فنية تحتاج إلى نقاش وأيضا وجود عيبٍ في الشفرة بحاجة إلى إصلاح

تفضل أخي @سامر محمود . واذا كان هذا طلبك لا تنسى الضغط على أفضل اجابة . AVIrep-1.accdb

تفضل أخي @Tarekfathallah ووافني بالرد . واذا كان هذا طلبك لا تنسى الضغط على أفضل اجابة . ترقيم خاص.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sort_Tbl() Dim sh As Worksheet Dim WStable As ListObject Set sh = ThisWorkbook.Sheets("Data") Set WStable = sh.ListObjects("الجدول1") Application.ScreenUpdating = False With WStable.Sort .SortFields.Clear .SortFields.Add2 Key:=Range("الجدول1[[#All],[المندوب]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlAscending .SortFields.Add2 Key:=Range("الجدول1[[#All],[الدولة]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add2 Key:=Range("الجدول1[[#All],[المنطقة]]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlAscending .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub فرز وتصفية.xlsb

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

وعليكم السلام -يمكنك استخدام هذه المعادلة =IFERROR(INDEX(ورقة1!B2:B270,MATCH(0,COUNTIF($A$1:A1,ورقة1!B2:B270),0)),"") تلخيص1.xlsx

ممكن اعرف تحديدا مقصدك هل تقصد المرفق الذى اضفته ام المرفق يعمل بنجاح ولكن عند محاكاته على تطبيق لم تعمل الاكواد بنجاح ؟!

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

اخي حاول توضيح المطلوب او ارفاق نتيجة للنتائج المتوقعة