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

اخي @mahmoud nasr alhasany خاصية ColumnHeads = True في عنصر التحكم ListBox لا تعمل إلا إذا كانت البيانات مرتبطة مباشرة بنطاق خلايا من ورقة العمل باستخدام خاصية RowSource عندما تستخدم الطريقة AddItem لإضافة البيانات يدويا لن يتم عرض رؤوس الأعمدة حتى لو قمت بتعيين ColumnHeads = True حاول إضافة رؤوس الأعمدة باستخدام عناصر Label بدلا من الاعتماد على رؤوس الأعمدة داخل الـ ListBox يمكنك تحديدها داخل كود تهيئة اليوزرفورم بعد اظافة عناصر label جديدة بعدد العناوين المرغوب عرضها وتسميتها بإسم مختلف لكي لا يتعارض الكود مع العناصر السابقة مثلا (hrd1- hrd2-...-hrd6) Private Sub UserForm_Initialize() 'الكود الخاص بك Dim arr As Variant arr = Array("كود", "صنف", "سعر", "كمية المخزون", "اسم المخزن", "تاريخ نهاية الصنف") For i = 1 To 6 Me("hrd" & i).Caption = arr(i - 1) Next i End Sub وتعديل الكود على Private Sub CommandButton1_Click() With ListBox2 .Clear .ColumnCount = 6 .ColumnWidths = colWidths .Font.Size = 10 End With currentRow = 0 For i = 2 To lastRow If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" Then ListBox2.AddItem ListBox2.List(currentRow, 0) = ws.Cells(i, 1).Value ' كود ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ' صنف ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ' سعر ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ' كمية المخزون ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ' اسم المخزن ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value ' تاريخ نهاية الصنف currentRow = currentRow + 1 End If Next i عملية بحث بشرطين او اكثر.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Private Sub TextBox1_Change() Dim WS As Worksheet: Set WS = ActiveSheet Dim LastRow As Long, OnRng As Range LastRow = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row Set OnRng = WS.Range("A2:AE" & LastRow) If Me.TextBox1.Value = "" Then If WS.AutoFilterMode Then WS.AutoFilterMode = False End If Else OnRng.AutoFilter Field:=3, _ Criteria1:=Me.TextBox1.Value & "*", Operator:=xlOr, Criteria2:=Me.TextBox1.Value End If End Sub

السلام عليكم اثراء للموضوع وتنوع الحلول وبعد اذن استاذنا الفاضل محمد هشام الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("L2:M2")) Is Nothing Then Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim outputRow As Long startDate = Me.Range("L2").Value endDate = Me.Range("M2").Value outputRow = 6 Me.Range("K6:L" & Me.Rows.Count).ClearContents For currentDate = startDate To endDate If Weekday(currentDate, vbSunday) <> 6 And Weekday(currentDate, vbSunday) <> 7 Then Me.Cells(outputRow, 11).Value = Format(currentDate, "dddd") Me.Cells(outputRow, 12).Value = currentDate outputRow = outputRow + 1 End If Next currentDate End If End Sub الملف تسلسل الأيام بدون أيام 2الجمعة والسبت.xlsm

تفضل جرب هل هدا ما تقصده Option Explicit Sub CreateDaysList() Dim Linge&, dCount& Dim startDate As Date, endDate As Date, n As Long Dim tmp As Date, cnt As String Dim sh As Worksheet: Set sh = Sheets("Sheet1") ' تحديد أقصى عدد للأيام المستخرجة Dim maxDays As Long: maxDays = 30 startDate = sh.[L2].Value: endDate = sh.[M2].Value If IsEmpty(sh.[L2].Value) Or IsEmpty(sh.[M2].Value) Or _ Not IsDate(sh.[L2].Value) Or Not IsDate(sh.[M2].Value) Or _ sh.[L2].Value > sh.[M2].Value Then MsgBox "تاريخ البداية أو النهاية غير صحيح", vbExclamation: Exit Sub End If tmp = startDate n = 0 Do While tmp <= endDate If Weekday(tmp) <> vbFriday And Weekday(tmp) <> vbSaturday Then n = n + 1 End If tmp = tmp + 1 Loop If n > maxDays Then MsgBox "عدد الأيام المستخرجة " & vbCrLf & _ "يتجاوز الحد الأقصى " & maxDays, vbExclamation Exit Sub End If Application.ScreenUpdating = False sh.Range("K6:L100").ClearContents Linge = 6 tmp = startDate dCount = 0 Do While tmp <= endDate If Weekday(tmp) <> vbFriday And Weekday(tmp) <> vbSaturday Then cnt = Choose(Weekday(tmp), "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس") sh.Cells(Linge, "L").Value = Format(tmp, "yyyy/mm/dd") sh.Cells(Linge, "K").Value = cnt Linge = Linge + 1 dCount = dCount + 1 End If tmp = tmp + 1 Loop Application.ScreenUpdating = True End Sub تسلسل الأيام بدون أيام الجمعة والسبت 2.xlsm

السلام عليكم لدي هذا الكود لمسار حفظ SavedPath = """" & CurrentProject.Path & "\Public_Library\r.pdf" & """" احتاج اضافة للكود ان يكون المسار في مجلد Public_Library ثم مجلد داخل هذا المجلد موجود مسبقا بحسب اسمة ياخذة عن حقل نصي في نفس النموذج اسمة Book_Name بمعنى احفظ هذا الملف في المجلد Public_Library في المجلد الذي اسمة موجود في الحقل النصي Book_Name

تفضل SavedPath = """" & CurrentProject.Path & "\Public_Library\" & Me.Book_Name & "\r.pdf" & """" SavedPath = CurrentProject.Path & "\Public_Library\" & Me.Book_Name & "\r.pdf"

مشاركة مع البشمهندس @Foksh هل هذا هو المطلوب ....

تفضل Dim rst As DAO.Recordset Dim i As Long Dim RC As Long Set rst = Forms!fnumbermain!fnumbersub.Form.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 0 To RC - 1 rst.Edit rst!num = 1 + i rst.Update rst.MoveNext Next i rst.Close: Set rst = Nothing MsgBox "Done"

أيضاً تأكد مما إذا كان الحل كما تريد أم لا ؟؟ قرض.accdb

جرب هذا ..... Dim rst As DAO.Recordset Dim biggest_Number As Long Dim i As Long Dim RC As Long biggest_Number = Len(DMax("[num]", "fnumber")) Set rst = CurrentDb.OpenRecordset("Select * From fnumber") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount For i = 0 To RC - 1 rst.Edit rst!num = 1 + i rst.Update rst.MoveNext Next i rst.Close: Set rst = Nothing MsgBox "Done"

تسلم أيدك يا فنان 🙂 فقط لاحظت أنني عندما أدخل أسمي كمستخدم جديد لا ينحفظ إلا إذا خرجت وفتحت النموذج من جديد 🙂

مبدع دائما

جواب السؤال اللولبي الأول ، دي طعم ومش هينفع تاخدها 🤣 والتانية انت لو خرجت هتروح فين ؟؟؟؟؟؟؟🤪 ولا انت عاوز تخسر وخلاص 😂 يبقى نرجع من مكان ما جينا 😉

نشكرك اخي @عبدالله بشير عبدالله على الملاحظة فعلا لم انتبه الكود يقوم بحساب أول يوم أحد بعد تاريخ البداية لذا إذا كان تاريخ البداية مثلا 1 ديسمبر وهو يوم الأحد بالفعل الكود سيقوم بحساب الأحد الذي يليه أي 8 ديسمبر تم تعديل الكود مع إظافة طلب أخونا @سعيد بيرم الأخير وهو قائمة فى ال M2 ولاكن على كامل الشهر دون إستثناء يومى الجمعة والسبت تعديل الدالة Function xdates(StartDate As Variant) As Variant Dim Dates() As Variant Dim Days() As String Dim Result() As Variant Dim tmp As Date, r As Date Dim n As Long, i As Long, maxday As Long If IsEmpty(StartDate) Or Not IsDate(StartDate) Then xdates = Array("") Exit Function End If maxday = 30 ' الحد الأقصى لعدد الأيام r = DateSerial(Year(StartDate), Month(StartDate) + 1, 0) ' العثور على أول يوم أحد tmp = StartDate + (7 - Weekday(StartDate, vbSunday)) Mod 7 If Weekday(StartDate, vbSunday) = 1 Then tmp = StartDate End If ReDim Dates(1 To maxday) ReDim Days(1 To maxday) For tmp = tmp To r ' تجاهل يومي الجمعة (6) والسبت (7) If Weekday(tmp, vbSunday) <= 5 Then ' أيام الأحد إلى الخميس فقط n = n + 1 Days(n) = Choose(Weekday(tmp, _ vbSunday), "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") Dates(n) = tmp If n >= maxday Then Exit For End If Next tmp ReDim Result(1 To n, 1 To 2) For i = 1 To n Result(i, 1) = Days(i) Result(i, 2) = Dates(i) Next i xdates = Result End Function والكود التالي لانشاء قائمة لايام الشهور المختارة واظافتها تلقائيا لخلية اختيار الشهر M2 مما يمكنه من تحديد بداية التاريخ المرغوب عرض بياناته Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim rCrit As Variant, startRow As Long, startCol As Long Dim MonthValue As Integer, YearValue As Integer Dim StartDate As Date, EndDate As Date, n As Date, r As Long On Error GoTo CleanExit startRow = 5 ' رقم الصف startCol = 11 ' العمود (K) If Not Intersect(Target, WS.Range("M2")) Is Nothing Then rCrit = xdates(WS.Range("M2").Value) WS.Range("K6:L30").ClearContents If Not IsEmpty(rCrit) Then Dim i As Long For i = LBound(rCrit) To UBound(rCrit) WS.Cells(startRow + i, startCol).Value = rCrit(i, 1) WS.Cells(startRow + i, startCol + 1).Value = rCrit(i, 2) Next i End If End If If Not Intersect(Target, WS.Range("N1,O1")) Is Nothing Then MonthValue = WS.Range("N1").Value YearValue = WS.Range("O1").Value If MonthValue < 1 Or MonthValue > 12 Or YearValue < 1900 Or YearValue > 2100 Then MsgBox "يرجى إدخال قيم صحيحة للشهر والسنة" Exit Sub End If StartDate = DateSerial(YearValue, MonthValue, 1) EndDate = DateSerial(YearValue, MonthValue + 1, 0) r = 5 n = StartDate WS.Range("Q5:Q50").ClearContents Do While n <= EndDate WS.Cells(r, 17).Value = n n = n + 1 r = r + 1 Loop Dim Rng As Range Set Rng = WS.Range(WS.Range("Q5"), WS.Range("Q" & r - 1)) With WS.Range("M2").Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & Rng.Address .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With WS.Range("M2").Value = StartDate End If CleanExit: End Sub معادلة اظافية لتوليد ايام الشهور بشرط شهر الخلية N2 والسنة في الخلية O2 =IF(ROW(A1) <= DAY(EOMONTH(DATE($O$1, $N$1, 1), 0)), DATE($O$1, $N$1, ROW(A1)), "") مع سحبها للاسفل بالتوفيق.............. V3 أيام الشهر من يوم محدد - vba.xlsm

هل هناك جزء غير مفهوم اخي ازهر

هدا بسبب عدم توافق نسخة الاوفيس لديك مع المعادلات المستخدمة على العموم لإثراء الموضوع أكثر اليك دالة تنفد المطلوب بادن الله عند التغيير في الخلية C2 Function xdates(StartDate As Variant) As Variant Dim Dates() As Variant Dim Days() As String Dim Result() As Variant Dim tmp As Date, r As Date Dim n As Long, i As Long, maxday As Long If IsEmpty(StartDate) Or Not IsDate(StartDate) Then xdates = Array("") Exit Function End If maxday = 30 ' الحد الأقصى لعدد الأيام r = DateSerial(Year(StartDate), Month(StartDate) + 1, 0) ' العثور على أول يوم أحد tmp = StartDate + (7 - Weekday(StartDate, vbSunday)) Mod 7 If Weekday(StartDate, vbSunday) = 1 Then tmp = StartDate End If ReDim Dates(1 To maxday) ReDim Days(1 To maxday) For tmp = tmp To r ' تجاهل يومي الجمعة (6) والسبت (7) If Weekday(tmp, vbSunday) <= 5 Then ' أيام الأحد إلى الخميس فقط n = n + 1 Days(n) = Choose(Weekday(tmp, _ vbSunday), "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") Dates(n) = tmp If n >= maxday Then Exit For End If Next tmp ReDim Result(1 To n, 1 To 2) For i = 1 To n Result(i, 1) = Days(i) Result(i, 2) = Dates(i) Next i xdates = Result End Function في الخلية A6 =xdates(C2) في حالة الرغبة بإستخراج النتائج قيم يمكنك وضع الكود التالي في حدث ورقة Sheet1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1") Dim rCrit As Variant, startRow As Long, startCol As Long On Error GoTo CleanExit startRow = 5 'رقم الصف startCol = 1 '(A)' أول عمود لوضع النتائج If Not Intersect(Target, Me.Range("C2")) Is Nothing Then rCrit = xdates(Me.Range("C2").Value) With f.Range("k6:l" & f.Rows.Count) .ClearContents End With If Not IsEmpty(rCrit) Then Dim i As Long For i = LBound(rCrit) To UBound(rCrit) f.Cells(startRow + i, startCol).Value = rCrit(i, 1) f.Cells(startRow + i, startCol + 1).Value = rCrit(i, 2) Next i End If End If CleanExit: End Sub قم تطبيق الفكرتين على نفس الملف لتختار ما يناسبك أيام الشهر من يوم محدد vba.xlsb

السلام عليكم في النموذج fnumber يوجد نموذج فرعي يحتوي ارقام قد تزيد وقد تنقص احتاج ترتيب هذة الارقم من 1 الى نهاية الارقام من خلال الزر الموجود في النموذج الرئيسي اي .......12345 بمعنى لوفرضنا انة لدي 50 سجل وتم حذف السجل رقم 40 يتم يصبح عدد السجلات 49 ويتم ارجاع القيمة بارجاع القيمة 40 المحذوفة بدل السجل 50 اتمنى ان تكون الفكرة واضحة numbers.accdb