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

Insert Module1 and paste the following code Option Explicit Private Sub ColorBySubject() Const STARTROW As Long = 8, STARTCOL As Long = 5, COLSNUM As Long = 4 Dim x, aCols, wsMarks As Worksheet, wsColors As Worksheet, rng As Range, sMarks As String, sQuote As String, sCell As String, n As Long, m As Long, ii As Long Application.ScreenUpdating = False With ThisWorkbook Set wsMarks = .Worksheets(1) Set wsColors = .Worksheets(2) End With Set rng = wsColors.Range("S8:S15") x = Application.Match(wsColors.Range("E3").Value, rng, 0) If Not IsError(x) Then sMarks = wsMarks.Name sQuote = WorksheetFunction.Rept(Chr(34), 2) n = wsMarks.Cells(Rows.Count, "C").End(xlUp).Row - 3 aCols = Array(5, 8, 11, 14, 17, 20, 23, 26) For m = 1 To 3 sCell = ColumnToLetter(aCols(x - 1) + m - 1) & "4" With wsColors If m <> 3 Then For ii = 4 To 1 Step -1 With .Cells(STARTROW, m * COLSNUM - ii + STARTCOL).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=" & ii & ",""0""," & sQuote & "))" End With Next ii Else With .Cells(STARTROW, 13).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & ">=3.5,""0""," & sQuote & "))" .Offset(, 1).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">=2.5," & sMarks & "!" & sCell & "<3.5),""0""," & sQuote & "))" .Offset(, 2).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">1," & sMarks & "!" & sCell & "<2.5),""0""," & sQuote & "))" .Offset(, 3).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=1,""0""," & sQuote & "))" End With End If End With Next m End If Application.ScreenUpdating = True End Sub Function ColumnToLetter(ByVal columnNumber As Long) As String If columnNumber < 1 Then Exit Function ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc("A"))) End Function Then in worksheet module (Colors) [The worksheet that has the data validation list], paste the following code Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$E$3" Then Application.Run "Module1.ColorBySubject" End If End Sub

السبب عدم تحديد مصدر لبياباتها في الجدول أو الاستعلام ..... اجعل لها حقل لتسجيل بياناتها ....

السلام عليكم و رحمة الله شاهد هذا المرفق ربما يكون هو طلبك يمكنك التعديل عليه بما يتوافق مع رغباتك ViewPicts.rar

خطأ لأنك تحتاجها في عميليات اخرى ... مثل الجرد نقل عهده ... الخ ..

مبدع استاذ @kkhalifa1960 طبعا المشروع جميل ..بس من اشوف الاسئلة كثيرة يصيبني الخمول 😄

وعليكم السلام تفضل اخي الكريم Private Sub cmdSearch_Click() Dim strSearch As String Static XC Dim rs As Object Set rs = Me.RecordsetClone Me.أمر26.Visible = False Me.أمر27.Visible = False Me.أمر29.Visible = False Me.أمر30.Visible = False Me.أمر32.Visible = False Me.أمر35.Visible = False If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then MsgBox "رجاء ادخل اسم للبحث عنه", vbOKOnly, "خطأ في البحث" Me![txtSearch].SetFocus Exit Sub End If strSearch = Me![txtSearch] With rs .FindNext "[emp_nam] like '*" & strSearch & "*'" If Not .emp_nam Like "*" & strSearch & "*" Then MsgBox "لا يوجد سجل بهذا الإسم : " & strSearch, vbCritical, "غير موجود" Me.txtSearch = "" Me![txtSearch].SetFocus ElseIf .NoMatch Then MsgBox "آخر سجل في البحث عن : " & strSearch, vbExclamation, "آخر سجل" Me.cmdSearch.Caption = "بحث" Me.txtSearch = "" Me![txtSearch].SetFocus Me.cmdSearch.ForeColor = RGB(0, 0, 255) Me.أمر26.Visible = True Me.أمر27.Visible = True Me.أمر29.Visible = True Me.أمر30.Visible = True Me.أمر32.Visible = True Me.أمر35.Visible = True DoCmd.GoToRecord , , acFirst rs.MoveFirst XC = 0 Else XC = XC + 1 Me.Bookmark = .Bookmark If XC = 1 Then MsgBox "تم ايجاد اسم : " & strSearch, vbInformation, "مبروك" Me.cmdSearch.Caption = "اكمال البحث" Me.cmdSearch.ForeColor = RGB(255, 0, 0) End If End With rs.Close Set rs = Nothing End Sub وهذا الملف بعد التعديل للعلم انا استخدم الاوفيس 2021 اذا لم يفتح معك الملف فقط انسخ الكود اعلاه وضعه تحت زر البحث ويجب عليك تغير مسميات الزر ونص البحث كما هو في الكود. تحياتي Database2023.accdb

استاذنا الفاضل lionheart شكرا جزيلا لحضرتك الكود يعمل بامتياز جزاك الله خيرا وانا عاجز عن الشكر

صراحة لم افهم المطلوب جيدا .

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

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

تفضل أستاذ @iyad mohamad طلبك كامل لكل مستخدم لابد يكون عنده نموذجان . النموذج (frm_MessageAllUsers) للكل للتنبيه فقط أو ماسج لكل المستخدمين .........أما النماذج frm_MessageUsers1) 1,2,3,4,5) لكل مستخدم نموذجه فقط لتنبيه المستخدم فقط أو ماسج . جرب ووافني بالرد . attention-1.rar

تفضل جرب اخي ووافينا بالنتيجة Sub RefreshData() ' تعديل Dim i As Long, k As Long Dim last_Dest As Long, lastrow As Long Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each ws_dest In ThisWorkbook.Worksheets lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row Application.ScreenUpdating = False For i = 2 To lastrow For k = 2 To last_Dest 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then ' شرط تطابق عمود التسلسل وعمود التوجيه If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _ ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _ 'في حالة تحقق الشرط ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value 'التاريخ ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value ' البيان ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value 'مدين ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value 'دائن ws_dest.Activate 'تسطير تلقائي للبيانات DL = ws_dest.Range("A65500").End(xlUp).row DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column ws_dest.Columns("A:F").Borders.LineStyle = xlNone ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If End If Next Next Next ws_dest ws_data.Activate MsgBox "تم التعديل بنجاح", 64 Application.ScreenUpdating = True End Sub Sub transfer_data() ' ترحيل Dim Sh As Worksheet Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each Sh In ThisWorkbook.Worksheets For R = 2 To [B20000].End(xlUp).row If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then Application.ScreenUpdating = False Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1) End If Next Next For Each Sh In Worksheets 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then Sh.Activate Sh.Range("A3:A1000").ClearContents Sh.Range("A3") = 1 Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear DL = Sh.Range("A20000").End(xlUp).row DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column Sh.Columns("A:F").Borders.LineStyle = xlNone Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If Next MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين" ws_data.Activate Application.ScreenUpdating = True End Sub استدعاء من عدة شيتات- V3.xlsm

سؤال لطيف.. الادارة والمدير وحدهم فقط لديهم صلاحية عرض نموذج الاجازات لكن موظف الادارة ..يقوم بصلاحية تعبئة الاجازة فقط..ولا تظهر عنده خيارات الموافقة او عدمها .. بينما المدير تظهر لديه تلك الخيارات

حسب نظام الصلاحيات عندك .. لو كان عامل للمدير صلاحيات خاصة تطبقها عند فتح النموذج .. مثال : If [forms]![LoginForm]![IsManager] = True Then Me.AgreeCbo.Visible = True Else Me.AgreeCbo.Visible = False End If بمعنى التحكم يكون بخاصية الظهور Visible للقائمة المنسدلة .. والطرق كثييييييييرة ومتنوعة 🙂

تفضل جاهز إن شاء الله جمع الكشوفات1 - ماكرو.xlsm

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

من غير أي شئ هذه كانت أخر مشاركة لي في هذا الموضوع .