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

ثم ماذا؟ ، أنا عملت خطواتك ولم تفتح مع الأكواد!!

السلام عليكم ورحمة الله اخولنى الكرام الكود التالى لنقل بيانات الغائبين من شيت data الى شيت غياب لجان غدا سأحاول تكملة الموضوع ان كان فى العمر بقية Sub AlAbst() Dim Data As Worksheet, ws As Worksheet Dim LR As Long, x As Integer Dim Arr As Variant, Tmp As Variant Dim Mad As String, Cls As String Dim i As Long, j As Long, p As Long Set Data = Sheets("data") LR = Data.Range("B" & Rows.Count).End(3).Row Set ws = Sheets("غياب لجان") ws.Range("A11:D100") = "" Mad = ws.Range("D8").Text x = WorksheetFunction.Match(Mad, Data.Range("A6:M6"), 0) - 1 Arr = Data.Range("B7:M" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, x) = "غ" Then p = p + 1 For j = 1 To 4 Tmp(p, j) = Arr(i, Choose(j, 4, 2, 1, 3)) Next End If Next If p > 0 Then ws.Range("A11").Resize(p, UBound(Tmp, 2)).Value = Tmp End Sub

تفضل اخي هذا مثال لطلبك Sub TEST_mh5() Dim ws As Worksheet Dim LR As Long Set ws = Worksheets("sheet2") Application.ScreenUpdating = False LR = ws.Range("B" & Rows.Count).End(xlUp).Row With ws.Range("c2:c" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,1,0)" .Value = .Value With ws.Range("d2:d" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,2,0)" .Value = .Value With ws.Range("E2:E" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,3,0)" .Value = .Value With ws.Range("F2:F" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,4,0)" .Value = .Value With ws.Range("G2:G" & LR) .Formula = "=VLOOKUP(""*""&b2&""*"",sheet1!A:E,5,0)" .Value = .Value End With End With End With End With End With End Sub جلب البيانات 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته كنت في انتظار رفع ملف للتطبيق عليه . بما انها مجرد فكرة وتريد حلها تفضل اخي الكريم يمكنك فعل دالك بواسطة الكود التالي لاستخراج مجموع القيم السالبة والموجبة وكدالك مجموع القيم المدخلة مع اضافة امكانية ظبط قيمة التغيير التي نعتمد عليها في الحساب في مثالنا هدا قد تم تنفيد طلبك مثلا اقول اذا كان التغيير هو 3 نقاط فا اكثر نبداء بالحساب ولكن اذا اكان التغيير اقل من 3 نقاط تجاهل الموضوع، وكان شيئا لم يحدث . ويمكنك ظبط القيمة كما تشاء من داخل الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$2" Then ' هنا ممكن ضبط قيمة اقل تغيير نعتمد عليه في الحساب' If Abs(Tmp - Target) < 3 Then Exit Sub Application.EnableEvents = False If Target < Tmp Then [m2] = [m2] + Tmp - Target 'عدد الاختلافات بالسالب' Else If Tmp <> 0 Then [g2] = [g2] + Target - Tmp 'عدد الاختلافات بالموجب End If Tmp = Target Application.EnableEvents = True End If If Target.Address = "$E$2" Then [b2] = [b2] + Target 'مجموع القيم المدخلة End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$E$2" Then Tmp = Target End Sub في حالة عدم الرغبة في وضع شرط اقل قيمة يمكنك استخدام الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = Me.[e2].Address Then Ecart = Target.Value - Me.[OldVal] Me.Names("OldVal").RefersTo = 0 + Target.Value Range("E2").Select Select Case Ecart Case Is > 0 Me.[g2] = Me.[g2] + Ecart Case Is < 0 Me.[m2] = Me.[m2] - Ecart Case 0 Range("b2").Value = Range("b2").Value + Target.Value End Select End If If Target.Address = "$E$2" Then [b2] = [b2] + Target End If End Sub واليك اخي الكريم الملف تم تطبيق الفكرة عليه للتجربة فكرة.xlsm

السلام عليكم تم عمل المطلوب في الملف المرفق، وذلك باستعمال الكود نفسه من موضوعك السابق الذي رابطه أمر طباعة الكل مع بعض التعديل... aشهادات .xlsm

https://drive.google.com/file/d/18lvYz7O4HSlY3YoaebqziLCub-ttEuRR/view?usp=drivesdk البرنامج في الرابط اعلاة تم تحميل البرنامج على درايف 1010089574_.zip

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

وعليكم السلام ورحمة الله تعالى وبركاته تقضل استاد فوزي ربما هدا ما تقصد Const MyWidth As Single = 80 Const MyHight As Single = 20 Private Sub TEST1() Dim WS As Range Dim Lf As Double, Tp As Double Dim ContColmn As Integer, r As Integer, c As Integer Set WS = Range("A3:I17") ContColmn = WS.Columns.Count For r = 1 To WS.Rows.Count l = 0 Lf = Me.Frame1.Width - 100 For c = 1 To ContColmn Lf = Lf - WS.Columns(c).Width With Me.Frame1.Controls.Add("Forms.Label.1") .BorderStyle = 1 .Move Lf, Tp, MyWidth, MyHight .Width = WS.Columns(c).Width Call TEST(.Name, WS.Cells(r, c)) End With Next Tp = Tp + MyHight c = 0 Next Set X = Nothing End Sub Private Sub TEST(iName As String, MyCel As Range) With Me.Controls(iName) .BackColor = MyCel.Interior.Color .Caption = MyCel.Text .TextAlign = 2 With .Font .Name = MyCel.Font.Name .Bold = True .Size = MyCel.Font.Size End With End With End Sub Private Sub UserForm_Initialize() Me.Frame1.SpecialEffect = 0 TEST1 End Sub عرض النتائج فى الفورم_1.xlsm

بل انت غصن غض والدليل عطاءك ..... بارك الله في عمرك وعملك ....

تفضل اخي تم تعويض زر اظهار الفورم بدوبل كليك على الصف الأول (عناوين الأعمدة) مع امكانية اضافة صورة حتى لو البيانات غير مكتملة. طلب وتعديل4.xlsm

السلام عليكم 🙂 ممكن نستخدم اول رقم وآخر رقم ID ، والتقرير يكون بين هذين الرقمين ، او نستخدم حقل vDate اللي عمله اخوي ابوخليل ، بتغيير بسيط ، فبدل ان تكون قيمته الافتراضبة =Date ، نجعلها =Now حتى نحصل على الوقت بالثواني (حتى يتمكن المستخدم من طباعة مرات اخرى في اليوم) ، والتقرير يكون بين هذين التاريخين 🙂 هذا كود زر المعاينة ، واستخدمت متغير بمعرف Variant ، حتى اقدر استخدمه لأي نوع ، سواء رقم او نص او تاريخ : Private Sub Command37_Click() 'save the last Record If Me.Dirty = True Then Me.Dirty = False Dim rst As DAO.Recordset Dim rFirst As Variant, rLast As Variant Dim myWhere As String Set rst = Me.RecordsetClone 'ID: rst.MoveFirst: rFirst = rst!ID rst.MoveLast: rLast = rst!ID '1 'myWhere = myWhere & " ID>=" & rFirst 'myWhere = myWhere & " And " 'myWhere = myWhere & " ID<=" & rLast '2 myWhere = "ID Between " & rFirst & " And " & rLast 'vDate: 'rst.MoveFirst: rFirst = rst!vdate 'rst.MoveLast: rLast = rst!vdate '3 'myWhere = myWhere & " vDate>=#" & rFirst & "#" 'myWhere = myWhere & " And " 'myWhere = myWhere & " vDate<=#" & rLast & "#" '4 'myWhere = "vDate Between #" & rFirst & "# And #" & rLast & "#" DoCmd.OpenReport "Report1", acViewPreview, , myWhere End Sub جعفر 1543.Print_Form_Records.accdb.zip

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

تأكد من اسم العنصر أو الحقل .

الاشياء المنطقية بالامكان تحقيقها .. في عالم البرمجة لا يوجد كلمة لا يمكن فما كان مستحيلا بالأمس يمكن تحققه اليوم وانت تريد مربع الحوار ان يظل مفتوحا لتختار الصور واحدة بعد الاخرى دون الرجوع الى الزر .. ولكن يجب ان نراعي بعض الأمور 1- وظيفة الزر انه يتفحص المتغيرات ليختار منها الذي لا يحمل قيمة 2- لكل متغير مربع صورة تخصه في النموذج 3- تصور انك ستجلب الصور من اكثر من مكان على الحاسب 4- في الغالب المرفقات عبارة عن مستند او صورة واحدة 5- لو سلمنا ان مربع الحوار سيبقى مفتوحا فسوف نضطر الى اغلاقه يدويا اخيرا رحم الله امرءاً عرف قدر نفسه .. فليس لدي تصور لتنفيذ الفكرة .. فلعل احد اخواننا الخبراء لديه تصور وتمكن من ذلك هذه يسيرة يمكنك عملها ... قم بتصغير المربعات واجعلها بجانب بعض واضف مربعا رابعا ولو كان خاليا واحط الكل باطار ..

أستاذ حمدي .. غير هذه إلى : strMSG = " || *" & Me.myname.Value & "*" & " ||" & vbcrlf & "|| *" & Me.msg.Value & "*" & " ||" & vbcrlf & "|| *" & Me.attach.Value & "* ||" & vbcrlf & "|| " & "المرسل : *" & Me.sub

وفي حالة وضع شرط لو الخلية فارغة يمكنك جعل الكود كالتالي With ws.Range("c2:c" & LR) .Formula = "=IF(B2="""","""",VLOOKUP(""*""&B2&""*"",sheet1!A:E,1,0))" .Value = .Value

العفو اخي الفاضل لقد حاولت تبسيط الكود الاول ليتم فهمه ربما تحتاج يوما ما للتعديل تفضل اخي اليك كود اخر يقوم بنفس المهمة لاكن حاول تجنب وضع علامة / بين الكلمات يمكنك استبدالها ب علامة (-) مثلا وسوف يشتغل معك الكود بكفاءة عالية بالتوفيق Sub Test_MH3() Dim a, b Dim I As Long, II As Long, LR As Long Dim j As Integer Dim ObjDic As Object Set ObjDic = CreateObject("Scripting.Dictionary") Dim K, T LR = Cells(Rows.Count, "A").End(3).Row a = Range("A2:D" & LR) For I = LBound(a, 1) To UBound(a, 1) ObjDic(a(I, 1)) = a(I, 2) & "/" & a(I, 3) & "/" & a(I, 4) Next I LR = Cells(Rows.Count, "e").End(3).Row b = Range("E2:E" & LR) ReDim Preserve b(LBound(b, 1) To UBound(b, 1), 1 To 5) For I = LBound(b, 1) To UBound(b, 1) For Each K In ObjDic.keys If K Like "*" & b(I, 1) & "*" Then T = Split(ObjDic(K), "/") b(I, 1) = K For II = 0 To UBound(T, 1) b(I, 2 + II) = T(II) Next II Exit For End If Next K Next I Cells(2, "F").Resize(UBound(b, 1), 4) = b End Sub نسخة من نسخة officene _3.xlsm

لا يمكنني تخمين موضع الحقول التي سيتم اظافتها يمكنك تعديله بنفس الطريقة عند اظافة حقول جديدة Sub TEST_MH2() Dim MT As Worksheet Dim lr As Long Set MT = Worksheets("sheet4") Application.ScreenUpdating = False lr = MT.Range("A" & Rows.Count).End(xlUp).Row MT.Range("F2:i" & lr).ClearContents With MT.Range("F2:F" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,1,0)" .Value = .Value With MT.Range("G2:G" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,2,0)" .Value = .Value With MT.Range("H2:H" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,3,0)" .Value = .Value With MT.Range("I2:I" & lr) .Formula = "=VLOOKUP(""*""&E2&""*"",A:D,4,0)" .Value = .Value End With End With End With End With Application.ScreenUpdating = True End Sub نسخة من نسخة officene _2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي نسخة من officene.xlsm

حياك الله أخي (Abu Rafat) .. تم التعديل أرجو التجربة. مقارنة (1).xls

Sub Committees_Absence() Rem Worksheets Dim wsData As Worksheet, wsCommittee As Worksheet Set wsData = ThisWorkbook.Worksheets(1) Set wsCommittee = ThisWorkbook.Worksheets(2) Rem Determine Subject Column Dim xSubject, iColSubject As Long xSubject = Application.Match(wsCommittee.Range("D8").Value, wsData.Range("F6:M6"), 0) If Not IsError(xSubject) Then iColSubject = xSubject + 5 Else MsgBox "No Such A Subject", vbExclamation: Exit Sub End If Rem Last Row In Data Worksheet Dim lrData As Long lrData = wsData.Cells(Rows.Count, "B").End(xlUp).Row Rem Absence Results In An Array Dim r As Long, n As Long ReDim aresults(1 To 1000, 1 To 4) For r = 7 To lrData If wsData.Cells(r, iColSubject).Value = Chr(219) Then n = n + 1 aresults(n, 1) = wsData.Cells(r, 5).Value 'Committee aresults(n, 2) = wsData.Cells(r, 3).Value 'Grade aresults(n, 3) = wsData.Cells(r, 2).Value 'Student Name aresults(n, 4) = wsData.Cells(r, 4).Value 'Seat Number End If Next r Rem Populate Results Dim iRow As Long With wsCommittee .Range("A11:F1000").ClearContents iRow = 11 If n > 0 Then .Range("A" & iRow).Resize(n, UBound(aresults, 2)).Value = aresults End With End Sub

وعليكم السلام ورحمة الله تعالى وبركاته العد.xlsx

السلام عليكم جارى عمل نسخ اعم واشمل من القديمة واضافة امكانيات اكبر واكثر من النسخة القديمة ولكن مع كل اعتذارى ساقوم بعرضها للبيع هنا فى اوفيسنا ايضا علما بان النسخة القديمة كانت مقتصرة على 3 انواع من المواشى اما النسخة الجديدة بيها امكانيه اضافة اى نوع من المواشى رقم الواتس الخاص بى 01008163186

السلام عليكم شكرا اخوتي انس ورضوان (زين سمعنا صوتك) وشفان بدأ الموضوع بعدة اسأله عن امكانية التعامل مع مواقع الانترنت ، ومعظمها عن ارسال البيانات ، وخصوصا لموقع الشموس ، وعلمنا اخونا العود أبوخليل (اعرف انه متابع الموضوع) ، ان الاسئلة المتكررة يعمل لها موضوع مستقل فيه حل شامل ، فانا هنا احاول الاقتداء به بدأ المشروع بشئ صغير ، ولكن الفكرة توسعت ، لتسهل العمل على المبرمج ، وليكون البرنامج مكتبة لعمل العديد من الاشياء. وهذا جعلني اتأخر عن بعض زبائني ، والتأخر عن مساعدة العديد من الشباب في المنتدى عمل البرنامج (طبعا لن يشتغل البرنامج على جميع المواقع ، وبالتجربة فقط تستطيع معرفة عمله مع اي موقع) : النموذج frm_browse يحتوي على كائن Microsoft Web Browser ، ندخل اسم الموقع في حقل التحرير والسرد url_Address ، ثم نضغط على الزر Go ، والذي سيفتح الموقع في النموذج ، الزر "احفظ csv" سيقرأ كائنات الموقع ، ويحفظها في ملف بصيغة csv (اللي ينفتح بالاكسل) ، ثم يفتح الملف ، وفيه 3 طرق لإرسال معلومات الى اي حقل تريد (يعني يعطيك الكود جاهز لكل حقل) ، والافضل استعمال الكود الذي في العمود "Usage2" ، حيث ليست جميع الحقول لها اسماء (للأسف في بعض المواقع) ، الأفضل منه هو زر "احفظ في الجدول" ، حيث سيحفظ كائنات الموقع في جدول في البرنامج نفسه ، والاصعب كان حفظ بيانات حقول التحرير والسرد ، الزر "تجربة ارسال ، استيراد بيانات لهذا الموقع" يفتح النموذج frm_Send_Get وبه كائنات الموقع واسماء الحقول (حسب اسمها في البرنامج وليس حسب ظهورها على الموقع ، فالموضوعين غير مرتبطين للأسف في برمجة الموقع) ، هنا نستطيع تجربة اذا كان بإمكاننا ارسال/استرجاع بيانات الى/من الموقع ، فتختار اي حقل تريد التجربة عليه ، وتكتب المعلومة التي تريد ارسالها في الحقل Send_Data وبالنقر المزدوج على المعلومة ، وسترى انه تم ادخالها في الحقل في الموقع ، ويمكن التأكد كذلك من امكانية قراءة معلومة الحقل بالنقر المزدوج على الحقل Get_Data ، بالنسبة لحقول التحرير والسرد ، فالموضع يختلف قليلا ، لأنه مثل الاكسس ، فالمعلومة التي تراها في اختيار المعلومة من هذا الحقل ، ليس معناه انها نفس القيمة التي تُحفظ في الجدول ، لذلك يجب عليك النقر المزدوج على الحقل ref_Name ، فيعطيك قائمة الاختيار من النموذج frm_Options ، وبالنقر المزدوج على الحقل Opt_Value ستنتقل المعلومة الى الحقل في Send_Data النموذج frm_Send_Get ، والتي يمكن بالنقر المزدوج عليها ان ترسل المعلومة الى الحقل في الموقع (وهنا قد لا ترى التغير على الحقل في الموقع ، ولكن عندما تنقر عليه لتختار ، ستجد ان الاختيار قد تم حسب رغبتك) ، الى هنا وقلت اقفل الموضوع!! ولكن ، صحيح اني قدمت كود ارسال/استرجاع البيانات ، وبيانات حقول التحرير والسرد ، ولكن العملية متعبة في عمل جدول جديد ونموذج وكود لكل حقل ووو ، فرأيت ان اواصل العمل ، ولم اعرف مدى صعوبة عمل والتحكم بقاعدة بيانات خارجية ، فلهذا السبب اخذ وقت اكثر بكثير مما كنت اعتقد: فعملت الزر "عمل نموذج ارسال ، استيراد بيانات لهذا الموقع" ، والذي يفتح النموذج frm_Make_Form ، والزر السحري فيه هو "اعمل النموذج" ، والذي: يعمل قاعدة بيانات جديدة ، حسب اسم المسار واسم البرنامج الذي تريده ، ويعمل فيها 4 جداول تحتوي على معلومات الموقع وكائناته ، ثم يعمل النموذج الخاص بهذا الموقع ، وتكون الحقول جاهزة للإستعمال ، مع حقول التحرير والسرد ، ويكون هذا النموذج مربوطا بالجدول tbl_web_Send_Get ، النموذج به زر "Send Data" وزر "Retrieve Data" ، العمل المتبقي هو عمل الكود لهذه الازرار ، بحيث يكون النموذج جاهز 99% ، وتبقى الـ 1% للتعديلات التي قد لا اطالها. ارفق لكم البرنامج الى حيث وصلت (مع العديد من الاشياء التجريبية التي يجب حذفها في البرنامج النهائي) ، وان شاء الله لما اكمل الجزء المتبقي ، سارفقه كذلك (حينها سأقوم بتعديل الموضوع من اول وجديد ، ترتيب الصور مع الشرح والمرفق الاخير ، ان شاء الله). جعفر Pre-WebBrowser.zip