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

Public Sub CMDSEARCH_Click() Dim x, ws As Worksheet, i As Long, j As Long, lastRow As Long With Me.ListBox1 .Clear .ColumnCount = 7 .ColumnWidths = "60 pt;150 pt;80 pt;150 pt;100 pt;70 pt;100 pt" .ColumnHeads = 0 Set ws = Sheets("Ledger") x = Application.Match(ComboBox1.Value, ws.Rows(1), 0) If Not IsError(x) Then lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row For i = 1 To lastRow If TextBox1 <> "" And InStr(ws.Cells(i, x), TextBox1) <> 0 Then .AddItem .List(j, 0) = ws.Cells(i, 1) .List(j, 1) = ws.Cells(i, 3) .List(j, 2) = ws.Cells(i, 4) .List(j, 3) = ws.Cells(i, 16) .List(j, 4) = ws.Cells(i, 17) .List(j, 5) = ws.Cells(i, 18) .List(j, 6) = ws.Cells(i, 10) j = j + 1 End If Next i End If End With End Sub

يمكنك استعمال هذه الدالة المعرفة Public Function MasIfs(ParamArray args() As Variant) As Variant Dim i As Integer Do Until CBool(args(i)) Or (i >= UBound(args)) i = i + 2 Loop If i < UBound(args) Then MasIfs = args(i + 1) End Function بالتوفيق

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

I think that's enough for this question. You can review this link

وعليكم السلام تفضل اخي الكريم Nouveau Microsoft Access Database.accdb Nouveau Microsoft Access Database.rar

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

لإضافة دالة معرفة udf نفتح نافذة محرر vba بالضغط alt+f11 من قائمة insert نختار module نلصق هذا الكود واستخدامها في اكسل مثل استخدام ifs ولكن نكتب masifs بالتوفيق

Sub Test() Dim a, tmp, i As Long, ii As Long, t As Long a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value a(1, 3) = a(1, 2) & " 1" With CreateObject("Scripting.Dictionary") For i = 2 To UBound(a, 1) If Not .Exists(a(i, 1)) Then .Item(a(i, 1)) = Array(.Count + 2, 3) tmp = a(i, 2) a(.Count + 1, 1) = a(i, 1) a(.Count + 1, 2) = a(i, 3) a(.Count + 1, 3) = tmp Else t = .Item(a(i, 1))(1) + 1 If UBound(a, 2) < t Then ReDim Preserve a(1 To UBound(a, 1), 1 To t) a(1, t) = Replace(a(1, 3), "1", t - 2) End If a(.Item(a(i, 1))(0), t) = a(i, 2) .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t) End If Next i t = .Count + 1 End With a(1, 2) = "Date" With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2)) .CurrentRegion.Clear .Value = a: .Borders.Weight = 2 .HorizontalAlignment = xlCenter .Columns.AutoFit .Parent.Select End With End Sub

Better to insert a column in the worksheet and populate the listbox from the column on the worksheet. Don't complicate your file

Here's the file You can click the button which has the caption [Click Here] or you can enter any value in column C in the first sheet to trigger the code GetUnique.xlsm

ألف مبروك . ونفع الله به وأعانه وزاد الجميع علما وحلما

Attach a new file with some data and the new output

الأسهل تصدير الملف بصيغة xlsx أو csv من خادم قاعدة البيانات ويمكن استعمال هذه الصفحة لتحويل الملف إلى اكسل https://www.convertcsv.com/sql-to-csv.htm بالتوفيق

بارك الله فيك و جعلك عونا للسائلين ، جزاك الله خيرا

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

الكود الاول والثانى روعة شكرا لكم

تفضل كل ماتريده داخل هذا البرنامج وهو لا حد الاساتذه الكرام GL.rar

جزاك الله خير يا أ / محمد

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

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

السلام عليكم صحيح السؤال غير واضح وكل واحد منا سوف يفسره حسب فهمه وصحيح ايضا لما قالوا : فهم السؤال نصف الإجابة انا فهمت ان د.حلبي يريد اظهار رسالة عند عدم وجود الصنف في الفرعي بناء على معلومتين : رقم الفاتورة / اسم الصنف وهذا الحل ان كنت فهمت Private Sub itemname_AfterUpdate() Dim i_name As String i_name = DCount("itemname", "t2", "masterid='" & Me.masterid & "'" & " And itemname='" & Me.itemname & "'") If i_name > 0 Then Exit Sub Else MsgBox "الصنف غير موجود" End If End Sub test2.accdb

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم تم الاستغناء عن كتابة الكود في مصدر تحكم Text20 وكتابته بعد البحث Me.Text20 = DSum("iAmount", "tbl_Items", "iPage <=1 " & " And [iBill_Number] = '" & Me.txtsearch & "'") DATA1041-5.rar تحياتي

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم If DCount("*", "t2", "itemname='" & Me.itemname & "'" & " and masterid ='" & Me.masterid & "'") > 0 Then MsgBox "صنف مكرر", vbInformation, "تحذير" DoCmd.CancelEvent End If test7.rar اخونا يسأل عن عدم تكرار الصنف في الفاتورة تحياتي

تفضل هذا التعديل open.zip

الله كريم اخي @alzahrani07وعلى قول عادل امام .. انا كبرت في دماغي 😂 تفضل حسب طلبك بعد بحث واستقصاء Serch_Database1 - Copy.accdb

Sub Test() Dim a, x, ws As Worksheet, sh As Worksheet, r As Range Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) Set r = ws.Range("C2:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) a = Application.Transpose(r.Value) With Application x = .Index(a, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & UBound(.Match(a, a, 0)) & ")")), .Match(a, a, 0), 0), "|"), "|", False)) End With sh.Range("B2:B" & Rows.Count).ClearContents sh.Range("B2").Resize(UBound(x)).Value = Application.Transpose(x) End Sub

Press Alt + F11 to open VBE editor > from Insert menu > Select Module > Paste the code I posted To run the code, press F5 when in VBE editor or go back to the worksheet and press Alt + F8 then select the macro name and finally click Run

I could save to PDF without any problems in the PDF output. May be you have to change the virtual printer that you use

First correct the combobox name from [Calss] to [Class] In userform module Dim ws As Worksheet, m As Long Private Sub StudentName_Enter() Dim a, i As Long, k As Long If Natija.Value <> "" And Class <> "" Then a = ws.Range("A2:D" & m).Value ReDim b(1 To UBound(a, 1)) For i = LBound(a) To UBound(a) If Val(a(i, 3)) = Val(Class.Value) And a(i, 4) = Natija.Value Then k = k + 1 b(k) = a(i, 2) End If Next i If k > 0 Then ReDim Preserve b(1 To k): StudentName.List = b End If End Sub Private Sub UserForm_Initialize() Dim a Set ws = Worksheets("Sheet1") m = ws.Cells(Rows.Count, "B").End(xlUp).Row a = GetDistinct(ws.Range("D2:D" & m)) Natija.List = a a = GetDistinct(ws.Range("C2:C" & m)) Class.List = a End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim vArr, v, dic As Object Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function

May be attaching the file solves the problem Zodiac Signs.xlsm

There are no events for the check boxes on form controls, but there is a workaround In standard module put the code Sub CheckBoxFormControl() Dim ws As Worksheet, cb As Shape, sChk As String, r As Long, c As Long Set ws = ActiveSheet With ws.CheckBoxes(Application.Caller) sChk = .Name r = .TopLeftCell.Row c = .TopLeftCell.Column End With If ws.CheckBoxes(Application.Caller).Value = 1 Then For Each cb In ws.Shapes If cb.Type = msoFormControl Then If cb.FormControlType = xlCheckBox And cb.Name <> sChk Then If cb.TopLeftCell.Row = r And cb.TopLeftCell.Column = c Then If cb.ControlFormat.Value = 1 Then cb.ControlFormat.Value = -4146 End If End If End If Next cb End If End Sub Now select only one check box then press Ctrl + A to select all the check boxes on the worksheet then right click and assign macro [CheckBoxFormControl] The code will loop through each check box in the same row only and uncheck any other check boxes except the one triggered by Application.Caller

وهذه محاولة ارجو ان يكون هو المطلوب mySQL = "Select * From tblData ORDER BY ID" Set rst = CurrentDb.OpenRecordset(mySQL) rst.MoveLast: rst.MoveFirst For i = 1 To Int(rst.RecordCount / 5) Me.List1.AddItem rst!CustCode rst.MoveNext Next For i = (List1.ListCount + 1) To (List1.ListCount + Int(rst.RecordCount / 5)) Me.List2.AddItem rst!CustCode rst.MoveNext Next For i = (List2.ListCount + 1) To (List2.ListCount + Int(rst.RecordCount / 5)) Me.List3.AddItem rst!CustCode rst.MoveNext Next For i = (List3.ListCount + 1) To (List3.ListCount + Int(rst.RecordCount / 5)) Me.List4.AddItem rst!CustCode rst.MoveNext Next For i = (List4.ListCount + 1) To (List4.ListCount + rst.RecordCount / 5) Me.List5.AddItem rst!CustCode rst.MoveNext Next rst.Close Test77.rar تحياتي

شاهد قناتي وان شاء الله سوف تستفيد

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

أخي الكريم من أساسيات البرمجة : * في حالة اختيار المستخدم لبديل واحد فقط يتم استخدام option button * في حالة اختيار المستخدم لأكثر من بديل نستخدم check box بوضوح أكثر: في مثل حالتك هذه يجب استخدام option button لأنك في الأخير تريد أن يكون عنصر واحد فقط هو المحدد بالتوفيق

فكرة بره الصندوق على اعتبار ان مصدر البيانات ثابت من 1 الى 35 Test.accdb

Sub Test() Dim cn As Object, rs As Object, i As Long With Worksheets("Data") Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") cn.Open ConnectionString:="Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;""" rs.Open "Transform First(Grade) Select ID, Gender, College, GPA, GPA2 From `" & .Name & "$A1:G` Where ID Is Not Null Group By ID, Gender, College, GPA, GPA2 Pivot Subject;", cn, 3 With Worksheets("Report").Range("A1") .CurrentRegion.ClearContents .Range("A2").CopyFromRecordset rs For i = 0 To rs.Fields.Count - 1 .Cells(1, i + 1) = rs.Fields(i).Name Next i End With End With Set cn = Nothing: Set rs = Nothing End Sub

تفضل إن شاء اللّه يفيدك هذا المرفق EXAMPLE.xlsb

السلام عليكم ورحمة الله كنت أنتظر أن يقوم أحد الإخوة الكرام بإنشاء ماكرو للقيام بهذه العملية وهذا لم يكن، لهذا قمت بتحضير ما تريده في الملف المرفق باستعمال المعادلات... وللضرورة قمت بتغيير التنسيقات على الجداول وإضافة المعادلات المناسبة لعمل المطلوب (يرجى أن لا تقوم بحذف الصفوف أو الأعمدة لئلا تخسر المعادلات)... يبقى لتغييراتك أن تقوم بحجز فقط عدد المناصب -عدد الأساتذة- حسب المواد في "جدول 1" (جدول المواد) وعدد الأفواج -عدد الأقسام- حسب الشعبة والمستوى- في "جدول 2" (جدول الأقسام) والمعادلات تقوم باللازم لملء الجداول الأخرى (حتى الجدول 3 في ورقة Data)... والله أعلم... جدول ديناميكي.xlsx

Many thanks for all of you

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

الف مبروك و الي الامام دائما باذن الله 🌼

Thank you very much Mr. Mohamed for your kind words and it is a great honor to be among you

قرار صائب من إدارة حكيمة @lionheartمنذ مشاركاته الأولى وأنا أشعر أنه أحد عمالقة هذا الصرح مليون مليار مبارك وأقترح عليه استعمال osk الموجودة في جميع إصدارات الويندوز أو touch keyboard الموجودة في ويندوز 10 فهما يدعمان اللغة العربية حتى وإن كانت لوحة المفاتيح hardware لا تدعمها خالص دعواتي بالتوفيق للجميع

Thank you very much for this trust. I am not expert, I am just a learner

حسب فهمي للمطلوب تم جعل صفحة الطباعة صفحة واحدة ويتم استدعاء باقي الصفحات بكتابة رقم الصفحة في الخلية E1 تم تلوين الخلايا التي وضع معادلات فيها ويمكنك زيادة عدد سجلات (صفوف) الصفحة وذلك باستبدال رقم 11 في المعادلات بالعدد المطلوب ونسخ المعادلات إلى الصف المطلوب لأسفل بالتوفيق ترحيل المجاميع.xlsx