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

هذا عمل بسيط مما تعلمته من هذا المنتدى الرائع ومن اساتذى الذى افتخر بهم فى كل مكان 2024صحيفة احوال - Copy.xlsm

In the first sheet module paste the following code Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long If Target.Row > 6 And Target.Column < 10 Then Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With lr = ws.Cells(Rows.Count, "C").End(xlUp).Row If lr >= 7 Then Set rng = ws.Range("D7:J" & lr) With rng Rem sh.Range("A6").Resize(.Rows.Count, .Columns.Count).Value = rng.Value rng.Copy sh.Range("A6") End With End If Application.ScreenUpdating = True End If End Sub the code will be executed as soon as you changed any cell in the range

بعد إذن الإخوة الكرام واثراءا للموضوع اليك اخي طريقتين يمكنك اختيار ما يناسيك الطريقة الاولى اظهار ورقة المستخدم بكلمة مرور مع اخفاء جميع الشيتات الاخرى يمكنك نعديل كلمات المرور كما تشاء الطريقة الثانية تحديد صلاحيات الوصول للمستخدمين دون اخفاء اوراق العمل بمعنى كتابة كلمة مفعل امام اوراق العمل المسموح للمستخدم الوصول اليها كما في الصورة المرفقة test1.rar test2.rar

تم ربط زر التبديل ب Get_Data_By_Subject قوائم لجان الدور الثاني - Copy.xlsb

I don't attach files if you don't know how to copy the code and use it, you have to learn the basics first before posting a question

@ابو حبيبه ربنا يبارك فيك وشكرا لمجهودك وهحاول اعمل زي ما قولتلي ولو في اي مشكله هكتبها @كريم نظيم تسلم وشكرا لمجهودك @Mohamed Hicham تسلم وشكرا ليك

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub test() Dim lR&, lRow& Dim Y As Range, R As Range Dim wsCopy As Worksheet: Set wsCopy = Sheets("Sheet1") Dim wsDest As Worksheet: Set wsDest = Sheets("Sheet2") lRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row Application.ScreenUpdating = False wsDest.Range("B10:K" & lRow).ClearContents With wsCopy lR = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(22, "B"), .Cells(lR, "E")).Copy wsDest.Cells(10, "B") End With With wsDest For Each Y In .Range("C10:C" & .Cells(Application.Rows.Count, 3).End(xlUp).Row) Set R = wsCopy.Columns(3).Find(Y.Value, , xlValues, xlPart) If Not R Is Nothing And R.Offset(0, 4).Value = "غ" Or R.Offset(0, 4).Value = "دون المستوى" Then Y.Offset(0, 3).Value = "X" If Not R Is Nothing And R.Offset(0, 6).Value = "غ" Or R.Offset(0, 6).Value = "دون المستوى" Then Y.Offset(0, 4).Value = "X" If Not R Is Nothing And R.Offset(0, 8).Value = "غ" Or R.Offset(0, 8).Value = "دون المستوى" Then Y.Offset(0, 5).Value = "X" If Not R Is Nothing And R.Offset(0, 10).Value = "غ" Or R.Offset(0, 10).Value = "دون المستوى" Then Y.Offset(0, 6).Value = "X" If Not R Is Nothing And R.Offset(0, 12).Value = "غ" Or R.Offset(0, 12).Value = "دون المستوى" Then Y.Offset(0, 7).Value = "X" If Not R Is Nothing And R.Offset(0, 14).Value = "غ" Or R.Offset(0, 14).Value = "دون المستوى" Then Y.Offset(0, 8).Value = "X" Next Y End With Application.ScreenUpdating = True End Sub OSAMA_V1.xlsm

تفضل أخي. وافني بالرد . DoCmd.TransferDatabase acExport, "Microsoft Access", "d:\b.mdb", acTable, "tbl2", "tbl2", False

جرب هذا المثال وبه استعانة بالكود ويمكن عمل كود آخر أثناء التصميم لتكرار صناديق التسميات إذا أحببت. Private Sub Report_Open(Cancel As Integer) Dim col As Byte, cols As Byte Dim acr As Byte, acrs As Byte Dim ctl0 As Control, ctl1 As Control, ctl2 As Control On Error Resume Next Me.Printer.ItemLayout = acPRVerticalColumnLayout Me.Printer.DefaultSize = False cols = Me.Section(0).Controls.Count acrs = Me.Printer.ItemsAcross Set ctl0 = Me("col" & Format(cols, "00") & "_01") Me.Width = Me.WindowWidth For acr = 2 To acrs For col = 1 To cols Set ctl1 = Me("col" & Format(col, "00") & "_01") Set ctl2 = Me("col" & Format(col, "00") & Format(acr, "_00")) With ctl2 .Left = ctl0.Left + ctl0.Width + IIf(col = 1, Me.Printer.ColumnSpacing, 0) .Top = ctl1.Top .Width = ctl1.Width .Height = ctl1.Height .BackColor = ctl1.BackColor .ForeColor = ctl1.ForeColor .BackStyle = ctl1.BackStyle .Caption = ctl1.Caption End With Set ctl0 = ctl2 Next col Next acr Me.Width = 0 With Me.Section(3) .Height = 0 .Height = .Height + Me.col01_01.Top End With Set ctl0 = Nothing Set ctl1 = Nothing Set ctl2 = Nothing End Sub تكرار عنوان التقرير_02.accdb

الشكر لله وحده. الحمد لله الذي بنعمته تتم الصالحات، وبفضله تتنزل الخيرات والبركات وبتوفيقه تتحقق المقاصد والغايات

نعم اخي ده مثال للفائدة فقط يمكنك تطويعه بما يناسبك وللعلم يمكن حدف اي ورقة من اوراق العمل سيقوم الملف بتحديث البيانات تلقائيا دون اي مشكلة اخي على العموم اليك الملف ب 3 اوراق فقط وورقة خاصة ب (Admin) لتعديل كلمات المرور test3.xlsm

الفكرة باعداد تقرير من عمودين او اكثر ثم تكرار حقول العنوان بعدد الاعمدة ولكن لابد من ضبط الهوامش وحجم الاعمدة بدقة انظر الصور المرفقة مع الاعتذار عن ارفاق مثال

مشاركة مع الاخ محمد ممكن ايضا عمل دالة تقوم بالمطلوب دون الحاجة الى استخدام دالة iif وما يتطلب من تكرارها وتكرار الشرط والنتيجة عند التحقق وعدم التحقق نعمل وحدة نضع فيها الامر Public Function n_fld(id As Integer) As String Dim rst As DAO.Recordset Dim fld As Field Dim t As String Set rst = CurrentDb.OpenRecordset("Select * From [صف خامس] Where [م1]= " & id) For Each fld In rst.Fields If fld.Type <> acTextBox Then If fld.Value = -1 Then t = t & " " & fld.Name End If End If Next n_fld = Replace(t, "تظلم", "") rst.Close End Function ويتم الاستدعاء في الاستعلام n_fld([م1]) والنتيجة ممكن تحسينها وكتابة التسميات بشكل افضل لتكون اكثر وضوح ولكن للاسف مالي مزاج

وعليكم السلام-تفضل قوائم 2021-.xlsb

مبروك الأستاذ Mohamed Hicham إنضمامك لعائلة الخبراء ,أسأل الله لك التوفيق والنجاح دائما ..وأعانك الله على هذه المسئولية الجديدة وسدد الله خطاك ..عن حق وجدارة بارك الله فيك وزادك الله من فضله

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

اضف المكتبة التالية

تفضل التعديل Database15.zip

للحصول على حجم ملف محدد استخدم الكود التالي في اي مكان داخل محرر الاكواد الصق الكود التالي Public Function GetFileSize(foldPath As String) As Double GetFileSize = FileLen(foldPath) / 1024 End Function و للإستخدام GetFileSize(" مسار الملف ")

ألف مليون مبروك للخبير

السلام عليكم lionheart اعتقد ان صاحب الملف كما قال انه لم يعطى له نتائج بسبب عدم اضافة الكود Get_Data_By_Subject الى زر او الى صفحةLagna فيكون كالاتي Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$L$3" Then Application.ScreenUpdating = False Range("B9:I28").ClearContents Application.ScreenUpdating = True End If Get_Data_By_Subject End Sub وهذا ملف كامل به كود استاذنا lionheart وقمت بالتجربة فتم استدعاء الطلبة حسب المادة حقيقة سرعة ابداع اتقان زادك الله رفعة وعلما استاذنا الفاضل الملف قوائم لجان الدور الثاني - Copy.xlsb

تمام شكرا تم التجريب بارك الله فيك

ألف ألف مبروك تستحقها بجدارة وفقك الله

بعد إذن أستاذى الجليل ومعلمى القدير الاستاذ @kkhalifa1960 لان استاذى الجليل هنا اعتمد على اسم السورة من العمود الثانى فى جملة بناء الاستعلام لمصدر بيانات مربع الســرد Combo2 ولانه لو اعتمد على الـ .value فستكون النتيجة هو رقم السورة من الحقل ID ولن تكون النتيجة مطابقة للرقم الاصلى للسورة لو تم حذف اى سجل واعادة تكرار ادخال بيانات لان الـ ID هنا ترقيم تلقائى وكان من الاولى اضافة حقل لرقم السورة كما هو مطابق لها فى الترتيب بالمصحف الشريف حتى بظل ثابت ولا يتغير بتغيير رقم الـ ID فى حالة الحذف والإضافة لاى سبب ولكن اثراء للأفكار يمكن الاعتماد على الرقم كذلك ان اردت باستخدام الـ .value من خلال استخدام الكود الأتى Select Case Nz(Combo2, "") Case Is = "": Me.Combo6 = "" Case Is = 8: Me.Combo6 = "" Case Else: Me.Combo6 = "بسم الله الرحمن الرحيم" End Select ولانى لا احبذ ولا احب استخدام الاحرف العربية داخل محرر الأكواد Select Case Nz(Combo2, "") Case Is = "": Me.Combo6 = "" Case Is = 8: Me.Combo6 = "" Case Else: Me.Combo6 = ChrW("1576") & ChrW("1587") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1604") & ChrW("1607") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1585") & ChrW("1581") & ChrW("1605") & ChrW("1606") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1585") & ChrW("1581") & ChrW("1610") & ChrW("1605") End Select

مشاركة مع الاخ @kkhalifa1960 بداية الاكسس يتيح عملها بدون الحاجة الى اكواد عن طريق استعلام الحاق ويتيح الحاق بيانات من جدول الى اخر في قاعدة اخرى وكذلك الحال يتيح امكانية انشاء جدول في قاعدة اخرى "البنية والبيانات او البنية فقط" بالنسبة لمشاركة الاخ خليفة ممكن اجراء تعديل بسيط من خلال انشاء نموذج يتم من خلاله اختيار مسار قاعدة البيانات وعمل قائمة لاختيار متعدد ليمكن تصدير جدول او اكثر بامر واحد -------------- اخيرا عند الله تجتمع الخصوم Database23.accdb

عاشت ايدك استاذنا الفاضل وهو المطلوب لكن اذا امكن توضيح لماذا استخدمت .colum ولم تسخدم .value يعني لماذا Me.Combo2.Column(1) ولم تكن Me.Combo2.Value وماهو الفرق بينهما علماً اني طبقت في المثال عندي حسب ما حضرتك عملت ولكن لم يعمل الكود ولما عدت إلى .value اشتغل الكود وما في اي مشكل ، ارجو التوضح لتعم الفائدة ولغرض التعلم من الامثلة مع فائق شكر وامتناني لك ولكل يساهم في العلم التعلم في هذا المنتدى .

تم اضافه مرفق في المشاركه الاساسيه لمعالجة مشاكل التشغيل التي تقابل الإخوة الاعضاء

تفضل استاذي . Database1-1.accdb

تفضل استاذي وأعتذر عن التأخير . DD151-1.Accdb

للمعلومة .. فما أجمل أن يكون الإنسان شمعة تُنير دروب الحائرين. يدفعنى الاندهاش الى المعرفة ، فيشعرنى بجهلى. جزاكم الله خيرا علي كل هذه الأعمال الرائعة @ابوحبيبه @Mohamed Hicham 🌹🌹

بعد السلام عليكم ورحمه الله وبركاته اتفضل لعله المطلوب تظليل الاعمدة.xls

جزاك الله خيرا عمل اكثر من رائع

اتفضل ارجو ان يكون المطلوب منظومة-الشؤون-الادارية-لمكتب-البصمى.xlsm

I don't attach files Wait someone to attach the file for you Just follow the steps and you will be able to make it run properly

The file is not perfect. Generally try the following code In standard module paste the following code Option Explicit Sub Get_Data_By_Subject() Const FIXEDROWS As Long = 20, FIXEDCOLS As Long = 5 Dim a, v, xCol, ws As Worksheet, sh As Worksheet, rng As Range, i As Long, ii As Long, k As Long, iStart As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False With ThisWorkbook Set ws = .Worksheets("ola"): Set sh = .Worksheets("lagna") End With a = ws.Range("B6:T102").Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) xCol = Application.Match(sh.Range("L3").Value, ws.Rows(5), 0) If Not IsError(xCol) Then For i = LBound(a) To UBound(a) If a(i, xCol - 1) <> Empty Then k = k + 1 For ii = LBound(a, 2) To UBound(a, 2) b(k, ii) = a(i, ii) Next ii End If Next i If k > 0 Then iStart = IIf(sh.Range("B9").Value = Empty, 1, sh.Range("B9").Value) Set rng = sh.Range("C9").Resize(FIXEDROWS, FIXEDCOLS) If iStart > k Then rng.ClearContents: GoTo Skipper v = ExtractArray(b, iStart, FIXEDROWS, FIXEDCOLS) sh.Range("B9").Resize(FIXEDROWS).Value = Evaluate("ROW(" & iStart & ":" & iStart + FIXEDROWS - 1 & ")") With rng .ClearContents .Value = v End With End If End If Skipper: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.ScreenUpdating = True End Sub Function ExtractArray(ByVal arr, ByVal iStart As Long, ByVal iRows As Long, ByVal iCols As Long) Dim i As Long, ii As Long ReDim outputArr(1 To iRows, 1 To iCols) For i = iStart To iStart + iRows - 1 For ii = 1 To iCols outputArr(i - iStart + 1, ii) = arr(i, ii) Next ii Next i ExtractArray = outputArr End Function In worksheet named Lagna paste the following module Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$L$3" Then Application.ScreenUpdating = False Range("B9:I28").ClearContents Application.ScreenUpdating = True End If End Sub By the way after selecting the subject click the down arrow of the spinner not the up arrow

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

حولوا المرفق إلى 2003 خلوني أحاول معكم.

تفضل تقسيم الى مجموعات.accdb

لو سمحتم محتاج اضافة جرد للاصناف لمعرف المتبقي منها ولكم جزيل الشكر فاتورة شراء وبيع المعدلة.xlsm

اتفضل اخى الكريم الملف لعله يفى بالغرض قوائم الفصول.xlsm

الاخوة الاعزاء المطلوب المساعدة فى تنفيذ التالى : 1- عند اختيار نوع الفاتورة على سبيل المثال فاتورة المبيعات يتم تحديد انواع المنتجات حسب نوع الفاتورة 2- حفظ بيانات الفاتورة فى شيت المشتريات عند اختيار فاتورة مشتريات وحفظ فاتورة مبيعات و فاتورة استلام بضاعة فى شيت المبيعات جزاكم الله خيرا حركة الاسمدة والمبيدات المعدل.xlsm

أخي الكريم .. إليك الكود التالي .. لا حاجة للاحتفاظ بالمعادلات في ورقة الهدف (النتائج) .. حيث وضعت لك دوال معرفة تقوم بنفس المهمة .. وتوفر عليك عناء كتابة وضبط المعادلات .. أدرج موديول جديد .. ثم ضع الكود التالي وجرب الكود وأخبرنا بالنتائج Option Explicit Sub TransferDataUsingArrays() Const startDate As Date = #10/1/2017# Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim temp As Variant Dim birthDate As Date Dim i As Long Dim j As Long Dim p As Long Set ws = Sheets("بيانات الطلاب") Set sh = Sheets("سجل 41 مستجدين") arr = ws.Range("B17:T" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value ReDim temp(1 To UBound(arr, 1), 1 To 18) For i = 1 To UBound(arr, 1) If arr(i, 5) = "مستجد" Or arr(i, 5) = "مستجدة" Then p = p + 1 For j = 1 To 18 temp(p, j) = arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 7, 8, 9, 13, 4, 14, 15, 16, 2, 11, 12, 17)) Next j temp(p, 1) = p On Error Resume Next birthDate = CDate(temp(p, 3) & "/" & temp(p, 4) & "/" & temp(p, 5)) temp(p, 7) = CalculateAge(birthDate, startDate, "d") temp(p, 8) = CalculateAge(birthDate, startDate, "m") temp(p, 9) = CalculateAge(birthDate, startDate, "y") On Error GoTo 0 temp(p, 15) = KhFatherName(CStr(temp(p, 2))) End If Next i If p > 0 Then With sh.Range("B8") .Resize(1000, UBound(temp, 2)).ClearContents .Resize(p, UBound(temp, 2)).Value = temp End With End If End Sub Function KhFatherName(ByVal Name As String) As String Dim khString As String Dim searchChar As String Dim khMid As String Dim khRep As String Dim khMyNo As Integer On Error GoTo Err_KhFatherName If IsEmpty(Name) Then GoTo Err_KhFatherName khString = KhFatherReplace(Trim(Name)) & " " searchChar = " " khMyNo = InStr(1, khString, searchChar, 1) khMid = Trim(Mid(khString, khMyNo, Len(khString))) khRep = Replace(khMid, "_", " ") KhFatherName = khRep Exit Function Err_KhFatherName: KhFatherName = "" End Function Private Function KhFatherReplace(ByVal Kh_Sub As String) As String Dim myArray As Variant Dim ar As Variant Dim sn As String Dim re As String myArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", " الزهراء") sn = Kh_Sub For Each ar In myArray re = Replace(ar, " ", "_") sn = Replace(sn, ar, re) Next ar KhFatherReplace = sn End Function Function CalculateAge(birth As Variant, start As Variant, str As String) Dim y As Long Dim m As Long Dim d As Long If Not IsDate(birth) Or Not IsDate(start) Then GoTo Skipper m = DateDiff("m", birth, start) d = DateDiff("d", DateAdd("m", m, birth), start) If d < 0 Then m = m - 1 d = DateDiff("d", DateAdd("m", m, birth), start) End If y = m \ 12 m = m Mod 12 Select Case str Case "d" CalculateAge = d Case "m" CalculateAge = m Case "y" CalculateAge = y End Select Exit Function Skipper: CalculateAge = "" End Function

السلام عليكم يمكنك الاطلاع على الملف التالى من خلال المصروفات والايرادات ورصيد بدايه المده تم انشاء القوائم الماليه واى حساب عندك اخر من المفترض اضافته حسب طبيعته مدين ام دائن -- بالمناسبه لم تذكر تلك البيانات المتاحه ورقيه او مدونه على الاكسيل -- عموما الملف التالى هو ملف اكسيل وقمت بتصويره لربما لا يكون عندك البرنامج وبالتالى اعتقد من خلال الصوره سيتضح كيف تم الامر Finincial reports.rar

السلام عليكم تم تحويل المعادلة المطلوبةإلي كود وهى =COUNTIF(INDEX($C$3:$EV$5000;0;0);$FA3) أعتقد أن الملف الآن مناسب book book4.rar

أخى الكريم الأستاذ // ناصر تم إضافة المطلوب ( طباعه الكل & طباعه ناجح & طباعة راسب ) على نفس نموذج الأستاذ // محمد All Certificates print_ FORM OR ALL OR PDF _By _MZMELSHRIEF+PR_N_R.rar

أخى الحبيب وأستاذى // ياسر خليل جزيتم عنى خير الخير ، وزادكم الله من نعمه أخى الكريم الأستاذ / محمد تجد بالمرفقات ملف به طباعه جميع الشهادات ومسح الشهادات وجمد قلبك وإضغط على مسح ومتقلقش، وتحويل أى شيت الى PDF أو أى نطاق الى PDF أو كامل المصنف الى PDF ممكن بعد إصدار أمر طباعة الكل يمكنك تحويل شيت الشهادات الى PDF All Certificates print_ FORM OR ALL OR PDF _By _MZMELSHRIEF.rar