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

وعليكم السلام إن كنت فهمت المطلوب فهذا التعديل Sub بحث_وانتقال() If Intersect(ActiveCell, Range("C6:C45")) Is Nothing Then Range("C6").Select Range("C6:C45").Find(Range("H2"), ActiveCell, xlValues).Select End Sub

امين واياك ....... طيب تفضل شوف كده استخدمنا هذه الاكواد ... Public Function PctMeter(varAmt As Variant, varTotal As Variant) Dim sngPct As Single sngPct = varAmt / varTotal If sngPct <= 1 Then Me!baselbl.Caption = Int(sngPct * 100) Me!lblmeter.Width = CLng(Me!baselbl.Width * sngPct) Else Me!baselbl.Caption = " القيمة أكبر من 100%" Me!lblmeter.Width = CLng(Me!baselbl.Width * 1) End If Select Case sngPct Case Is < 0.15 Me!lblmeter.BackColor = 255 Me.red_p.Visible = True Me.gre_p.Visible = False Me.yel_p.Visible = False Case Is < 0.5 Me!lblmeter.BackColor = 65535 Me.red_p.Visible = False Me.gre_p.Visible = False Me.yel_p.Visible = True Case Else Me!lblmeter.BackColor = 65280 Me.red_p.Visible = False Me.gre_p.Visible = True Me.yel_p.Visible = False End Select End Function Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) i = 1 For i = i To 5 If (Me("Text" & 19 + i) / Me.Text25) * 100 < 20 Then Me(i & "_red").Visible = True Me(i & "_ger").Visible = False Me(i & "_yel").Visible = False ElseIf (Me("Text" & 19 + i) / Me.Text25) * 100 > 20 Then Me(i & "_red").Visible = False Me(i & "_ger").Visible = True Me(i & "_yel").Visible = False End If Next i Call PctMeter(Me.bar, 100) End Sub New Database - .accdb

تفضل عمل احصائية.xlsm

تفضل جرب هذا مجموع مدد.xlsx

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

شكراً أ. محمد صالح على مشاركتك القيمة

تفضل bdd2 (5).accdb

الاخ العزيز المشكلة عندك فى اللغة للكمبيوتر الخط عندى واضح عند العرض

الفكرة في انشاء وحذف المجلدات في vba مشابهه لاوامر cmd ولكوني غير متخصص فقط سوف اشير الى طريقة انشاء وحذفة المجلد في vba واترك الامر للاساتذه والخبراء صيغة انشاء مجلد MkDir CurrentProject.Path & "\ااسم المجلد\" لحذف المجلد RmDir CurrentProject.Path & "\اسم المجلد\" ويمكن تسمية المجلد من خلال تسمية مباشرة او من خلال حقل في النموذج او اسناد التسمية الى متغير وهكذا ويمكن التأكد من وجود المجلد قبل تنفيذ الامر من خلال If Len(Dir(CurrentProject.Path & "\اسم المجلد\", vbDirectory)) = 0 Then وبناء على النتيجة تنفذ الامر الذي تريده وهنا يتوقف الاخ شايب 🌹

بالتوفيق للجميع

شكرا جدا لحضرتك علي تعبك معايا

(إنا لله وإنا إليه راجعون) اللهم إرحمه برحمتك الواسعة وأدخله فسيح جناتك بفضلك وكرمك رب العالمين

تعليق لاخونا العزيز شايب في برامج المبيعات يتطلب وجود جدول واحد للاصناف او اكثر حسب طريقة المبرمج مثلا جدول الاصناف وجدول ترميز الاصناف وطلب الاستاذ ابو عبد الرحمن ادراج صنف في فاتورة المبيعات خارج قائمة الاصناف المتوفرة امر غير مالوف الا اذا كان المقصود في حالة عدم وجود الصنف يتم ادحاله مباشرة في الفاتورة ويحفظ ايضا في جدول الاصناف وهذا ايضا قد يسبب مشكلات من حيث تكرار اصناف باسماء مختلفة مثل زيت زيتون واخر زيت الزيتون .... وهكذا وايضا قد يحصل صنف واحد على اكثر من كود للصنف بينما يفترض بكود الصنف ان يكون معرف فريد للصنف ايضا من مروري بشكل سريع على البرنامج وجدت انه تم استخدام دالة DLookup في حدث بعد التحديث للقائمة بهذا الشكل Me.SellingPrice = DLookup("[SellingPrice]", "TaItems", "ItemID=" & [ItemName]) Me.SellingPrice2 = DLookup("[SellingPrice]", "TaItems", "ItemID=" & [ItemName]) Me.ItemDiscount = DLookup("[ItemDiscount]", "TaItems", "ItemID=" & [ItemName]) Me.PurchasPrice2 = DLookup("[PurchasPrice]", "TaItems", "ItemID=" & [ItemName]) Me.SellingPrice2 = DLookup("[SellingPrice]", "TaItems", "ItemID=" & [ItemName]) Me.ItemDiscount2 = DLookup("[ItemDiscount]", "TaItems", "ItemID=" & [ItemName]) Me.LowestPrice2 = DLookup("[LowestPrice]", "TaItems", "ItemID=" & [ItemName]) اي كاننا ننفذ سبعة استعلام عند ادراج كل صنف بينما كان يمكننا تحميل قيمة الحقول السبعة بامر واحد وسبق شرحه في الموقع او الاستغناء عن DLookup بتحميل قيمة الحقول السبعة عن طريق الاستعلام ثم اسناد قيمة كل حقل بحسب موقعة في القائمة me.ItemName.Column(0) me.ItemName.Column(1) me.ItemName.Column(2) وهكذا وجهة نظر ونترك الامر للاساتذة والخبراء الاخ شايب 🌹

Try Private Sub CommandButton1_Click() Dim mySum As Double, i As Long With Me.ListBox1 For i = 0 To .ListCount - 1 mySum = mySum + Val(.List(i, 1)) Next i End With Me.TextBox1.Value = mySum End Sub

لم افهم قصدك اخي الفاضل ولعل خبراء منتدانا الرائع يشاركونا ما تحتاجه

وعليكم السلام تفضل الفرق بين تاريخين.xlsx

آمل أن يكون هذا ما تريد سجلات0.xlsb

السلام عليكم ورحمه الله وبركاته تفضل لعله المطلوب سجلات0 (1).xlsb

تفضل Dim SetRep As Variant, SetRepNew As Variant SetRep = "ضع اسم التقرير هنا" SetRepNew = CurrentProject.Path & "\" & [ID] & ".pdf" DoCmd.OpenReport SetRep, acViewPreview DoCmd.OutputTo acOutputReport, SetRep, "PDFFormat(*.pdf)", SetRepNew, True

هكذا؟ Sub test() Dim dic1 As Object: Dim dic2 As Object Dim a, b, w, bb Dim i& a = Sheets("فودا").Cells(1).CurrentRegion b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2)) bb = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(1)) Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") For i = 2 To UBound(a) If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then If Not dic1.exists(a(i, 3)) Then dic1.Add a(i, 3), Array(a(i, 3), bb(Application.Match(a(i, 3), b, 0)), a(i, 7)) Else w = dic1.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic1.Item(a(i, 3)) = w End If Else If Not dic2.exists(a(i, 3)) Then dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7)) Else w = dic2.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic2.Item(a(i, 3)) = w End If End If Next With Sheets("رحل") Union(Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)), Range(.Cells(3, 8), .Cells(3, 11).End(xlDown))).ClearContents .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0) .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0) End With End Sub

عليكم السلام عسى أمون قد فهمت الموضوع صح جرب هذا Sub test() Dim dic1 As Object: Dim dic2 As Object Dim a, b, w, xx Dim i& a = Sheets("فودا").Cells(1).CurrentRegion b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2)) Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") For i = 2 To UBound(a) If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then If Not dic1.exists(a(i, 3)) Then dic1.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7)) Else w = dic1.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic1.Item(a(i, 3)) = w End If Else If Not dic2.exists(a(i, 3)) Then dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7)) Else w = dic2.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic2.Item(a(i, 3)) = w End If End If Next With Sheets("رحل") Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)).ClearContents Range(.Cells(3, 8), .Cells(3, 11).End(xlDown)).ClearContents .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0) .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0) End With End Sub

تفضل اخي عدل هذا السطر If (X.Row < 600 And X.Column < 12) Then الى If (X.Row >= 100 and X.Row <= 120 And X.Column < 4) Then

وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل اخي @ehabaf2 Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim X As Range For Each X In Target ' 600 هو اخر سطر لعمل الكود 'L هو العامود column 12 If (X.Row < 600 And X.Column < 12) Then If ActiveSheet.ProtectContents = True And X.Value <> "" Then X.Offset(0, 1).Select End If Next End Sub عدم التعديل فى اسطر محددة.xlsb

تفضل جرب Option Compare Text Dim f, Rng, wsData() Private Sub UserForm_Initialize() Set f = Sheets("التقرير") Set Rng = f.Range("A3:j" & f.[A65000].End(xlUp).Row) wsData = Rng.Value Me.ListBox1.List = wsData Me.ListBox1.ColumnCount = 10 Me.ListBox1.ColumnWidths = "120;65;65;80;80;65;80;65;80;65" Me.combobox1.List = Application.Transpose(Rng.Offset(-1).Resize(1)) Me.combobox1.ListIndex = 0 Me.LabelColFiltre.Caption = "بحث ب :" & Me.combobox1 End Sub Private Sub combobox1_click() Me.LabelColFiltre.Caption = "بحث ب: " & Me.combobox1 End Sub Private Sub TextBox1_Change() Réf_Colmun = Me.combobox1.ListIndex + 1 clé = "*" & Me.TextBox1 & "*": n = 0 Dim A() For i = 1 To UBound(wsData) If wsData(i, Réf_Colmun) Like clé Then n = n + 1: ReDim Preserve A(1 To UBound(wsData, 2), 1 To n) For k = 1 To UBound(wsData, 2): A(k, n) = wsData(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = A Else Me.ListBox1.Clear End Sub بحث في الفورم.xlsb

بحث في الفورم.xlsb

ربما Sub test() Dim r& With ActiveSheet r = .Cells(Rows.Count, 4).End(xlUp).Row .Range("D4:I" & r).SpecialCells(4).Delete Shift:=xlUp .Range("$D$3:$D$" & r).RemoveDuplicates 1, 1 End With End Sub

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

التغيير سيكون في macro1 اجعله هكدا Public gtxtCalTarget As Variant Public Function LogError(lngErr As Long, strDescrip As String, strProc As String, _ Optional bShowUser As Boolean = True, Optional varParam As Variant) If bShowUser Then MsgBox "Error " & lngErr & ": " & strDescrip, vbExclamation, strProc End If End Function Public Function CalendarFor2(txt As Variant) On Error GoTo Err_Handler gtxtCalTarget = TextBox1 GalendarForm.Show Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation, "CalendarFor()" Resume Exit_Handler End Function وبعد اظافة الصورة مثلا Private Sub Image1_click() Call CalendarFor2(Me.TextBox1) End Sub اليك المرفق بعد اظافة تقويم جديد يمكنك اختيار ما يناسيك يوزر فورم 2 التقويم.xlsm

عسى ان ينال الاعجاب Allah_Akbar.rar