عبدالله بشير عبدالله

السلام عليكم ورحمة الله بركاته مبدع دائما معلمنا Foksh ملاحظنان للاستاذ جلال محمد الاولى في بداية اكواد الفورم Private Const DATE_COL_START As Long = 7 قم بتعديل 7 الى 5 وهو اول عمود به تاريخ في الشيت الملاحظة الثانية الخيار الاخير في القورم غياب مدة بين تاريخين لعدة فصول وتاتى رسالة MsgBox "اختر فصل واحد على الأقل", فاذا كان الخيار فصل واحد لا مشكلة ولكن اذا اردنا اختيار اكثر من فصل فلا توجد وسيلة لذلك لان الفصول في الكائن cmbClass هو ComboBox، وليس ListBox، ولذلك لا يحتوي على خاصية .Selected(index)، فهي خاصة بالكائنات التي تسمح بتحديد متعدد مثل ListBox من النوع fmMultiSelectMulti فاعتقد استبدال cmbClass ب ListBox افضل للخيار الاخير لكما وافر التقدير والاحترام

السلام عليكم ورحمة الله وبركاته يمكن بواسطة معادلة =IFERROR(AVERAGEIFS(table1!$A:$A; table1!$C:$C; $C5; table1!$E:$E; D$4);"") او كود يفوم بجلب الاصناف مع متوسط كل صنف Sub حساب_المتوسط_و_جلب_الاصناف() Dim wsIn As Worksheet, wsOut As Worksheet Dim lastRowIn As Long Dim dataArr As Variant Dim i As Long Dim prod As String, price As Double Dim dt As Variant, mon As Long Dim sums As Object, counts As Object, uniqueProds As Object Dim key As String Dim prodList As Variant Dim r As Long, c As Long Dim lastRowOut As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set wsIn = Sheets("table1") Set wsOut = Sheets("sheet1") Set sums = CreateObject("Scripting.Dictionary") Set counts = CreateObject("Scripting.Dictionary") Set uniqueProds = CreateObject("Scripting.Dictionary") lastRowIn = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row If lastRowIn < 2 Then Exit Sub dataArr = wsIn.Range("A2:D" & lastRowIn).Value For i = 1 To UBound(dataArr, 1) prod = CStr(dataArr(i, 3)) dt = dataArr(i, 4) If Len(prod) > 0 And IsDate(dt) Then mon = Month(dt) price = dataArr(i, 1) key = prod & "_" & mon If Not sums.Exists(key) Then sums(key) = 0 counts(key) = 0 End If sums(key) = sums(key) + price counts(key) = counts(key) + 1 If Not uniqueProds.Exists(prod) Then uniqueProds(prod) = True End If End If Next i wsOut.Range("C5:C10000").ClearContents prodList = uniqueProds.Keys For i = 0 To UBound(prodList) wsOut.Cells(5 + i, "C").Value = prodList(i) Next i lastRowOut = wsOut.Cells(wsOut.Rows.Count, "C").End(xlUp).Row For r = 5 To lastRowOut prod = wsOut.Cells(r, "C").Value For c = 4 To 15 mon = wsOut.Cells(4, c).Value key = prod & "_" & mon If sums.Exists(key) Then wsOut.Cells(r, c).Value = sums(key) / counts(key) Else wsOut.Cells(r, c).ClearContents End If Next c Next r Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub تحيانى لك ولمعلمنا الفاضل أ / محمد صالح متوسط الاصناف كود.xlsb متوسط الاصناف معادلة.xlsx

السلام عليكم ورحمة الله وبركاته الكود المرفق في طلبك الاول لا يتناسب مع وافع الملف وخصوصا النطاقات K13:KJ - H14:H فهي ليس لها اهمية خسب ملفك المرفق اليك التعديل حسب فهمى لفكرة عمل ملفك يتم ما تم ترخيله باللون الاصفر ويمكن الغائها من الكود بحذف السطر w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) الكود Sub dahmour() Dim w As Workbook Dim L As Variant Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Dim colNum As Long Dim matched As Boolean Dim rng As Range, cellDate As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").Range("D2").Value If L = "" Then MsgBox "يرجى اختيار التاريخ من الخلية D2!", vbExclamation Exit Sub End If r1 = w.Sheets("Sheet2").Cells(w.Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Galal").Cells(w.Sheets("Galal").Rows.Count, 1).End(xlUp).Row Set rng = w.Sheets("Galal").Range("E7:Z7") c = 0 For Each cellDate In rng If IsDate(cellDate.Value) And IsDate(L) Then If CDate(cellDate.Value) = CDate(L) Then c = cellDate.Column Exit For End If End If Next cellDate If c = 0 Then MsgBox "لم يتم العثور على التاريخ '" & L & "' في الصف 7 من ورقة Galal", vbCritical Exit Sub End If If IsNumeric(w.Sheets("Sheet2").Range("K4").Value) Then colNum = w.Sheets("Sheet2").Range("K4").Value Else MsgBox "الخانة K4 يجب أن تحتوي على رقم العمود المراد ترحيله!", vbExclamation Exit Sub End If matched = False For Each cell In w.Sheets("Sheet2").Range("A11:A" & r1) If Trim(cell.Value) <> "" Then For Each cell2 In w.Sheets("Galal").Range("A8:A" & r2) If Trim(cell.Value) = Trim(cell2.Value) Then w.Sheets("Galal").Cells(cell2.Row, c).Value = w.Sheets("Sheet2").Cells(cell.Row, colNum).Value w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) matched = True Exit For End If Next cell2 End If Next cell If matched Then MsgBox "تم الترحيل بنجاح!", vbInformation Else MsgBox "لم يتم العثور على أي رقم جلوس مطابق!", vbExclamation End If End Sub الملف غياب1.xlsm

السلام عليكم ورحمة الله وبركاته يتم التعديل في المتغيرات إزالة المتغير w2 لأننا لن نستخدم ملف خارجي تغيير جميع الإشارات من w2.Sheets("Total") إلى w.Sheets("Sheets3") للعمل مع الشيت المطلوب في نفس الملف اسم الشيت المرحل اليه Sheets3 Sub dahmour() Dim w As Workbook Dim L As String Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").[d2].Value If L <> "" Then r1 = w.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Sheets3").Cells(Rows.Count, 1).End(xlUp).Row c = w.Sheets("Sheets3").Range("K13:KJ13").Find(L, LookAt:=xlWhole).Column For Each cell In w.Sheets("Sheet2").Range("a11:a" & r1) For Each cell2 In w.Sheets("Sheets3").Range("H14:H" & r2) If cell2.Value = cell.Value Then w.Sheets("Sheets3").Cells(cell2.Row, c) = w.Sheets("Sheet2").Cells(cell.Row, [k4]).Value Exit For End If Next cell2 Next cell End If End Sub

وعليكم السلام ورحمة الله وبركاته الأخ الكريم صاحب الكلمة الطيبة والمشاعر النبيلة، الفاضل / algammal أسعد الله قلبك كما أسعدتنا بكلماتك التي فاحت منها الطيبة والوفاء، ووالله إنها لوسام على صدورنا، ودافع لنا لنستمر في العطاء ما حيينا. نحن لم نقدّم إلا واجبًا يسيرًا، وما نحن إلا تلاميذ في هذا الصرح الطيب، ننهل ونتعلم ونتشارك. وسعادتنا الحقيقية أن نرى ثمرة هذا التعاون في نفوس طيبة مثلكم. بمناسبة عيد الأضحى المبارك، أتقدّم إليك وإلى جميع الإخوة والأعضاء الكرام بأطيب التهاني والتبريكات، أعاده الله علينا وعليكم بالخير واليمن والبركات، وتقبّل الله طاعاتكم، وبلغكم منازل الأبرار ‏، وأكرمكم بالعفو والعافية والغفران ، ووفقكم لما يحب ربنا ويرضاه ، لكم مني خالص المحبة والتقدير،

وعليكم السلام ورحمة الله وبركانه لم توضح ارتباط العمود الثاتي بأيعم ود في الشيت اليك التعديل Private Sub TextBox1_Change() ListBox1.Clear Application.ScreenUpdating = False Dim ws As Worksheet: Set ws = Sheets("add") Dim lr As Long, c As Range, b As Integer, k As Long Dim arrData() As Variant Dim i As Long, j As Long lr = 0 For Each c In ws.Range("b5:b" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) b = InStr(1, c.Value, TextBox1.Value, vbTextCompare) If b > 0 Then lr = lr + 1 ReDim Preserve arrData(1 To 2, 1 To lr) arrData(1, lr) = c.Value arrData(2, lr) = c.Offset(0, 4).Value End If Next c With ListBox1 .ColumnCount = 2 .ColumnWidths = "100;100" If lr > 0 Then .List = Application.Transpose(arrData) End If End With Application.ScreenUpdating = True End Sub في الكود السابق تم ربط العمود الثاني باسم المعلم يمكنك التعديل يالتغيير في رقم 4 فهي تشير الى رقم العمود في الشيت بعد عمود الاسم arrData(2, lr) = c.Offset(0, 4).Value كنا يمكنك من تعديل عرض العمود بالتعديل في رقمي 100 الاول للعمود الاول والثانية للعمود الثاني .ColumnWidths = "100;100" ارجو ما قدمته ان يكون طلبك كل عام وانت بخير المرحليات أوفيسنا.xlsm

السلام عليكم ورحمة الله وبركاته تم تحسين سرعة الكود اي تغيير في I2 -13-14 يعمل الكود الترقيم التلقائي في العمود B تم تعديل المعادلة في العمود الاخير بحيت تظعر الارقام حيب اخر بيان في العمود C جرب الكود وان كان هناك أي استفسار فلا حرج اعاده الله عليك يالخير والبركة يومية النقدية 1العامة.xlsm

السلام عليكم ورحمة الله وبركاته بعد ملاحظة ااستاذنا الفاضل محمد هشام. جزاه الله خيرا والتي ذكر فيها بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير وتعليقكم وكما اشار معلمنا الفاضل اليك الملف يبحث بعدة معايير لكما كل الود والتقدير والاحترام طريقة اخرى للبحث بعدة معايير.xlsb

وعليكم السلام ورحمة الله وبركاته 4 طرق لمسح البيانات 1- زر به كود مسخ البيانات (جديد) يقوم الزر بنفس وظيفة الخلية الفارغة 2- اخنيار الخلية الفارغة من E5 (بعد عمل زر المسخ ليس لها ضرورة ) 3- الخروج من شيت SEARCH ثم العودة اليه 4- النقر مرتين في اي خلية في شيت SEARCH وايسرها كما تفضلتم زر المسح او النقر مرنين كما انوه ان تحديث البيانات اظافة وظيفة جديدة ..... الخ الى شيت DATA او معاشات يتم تلقائيا مع الانتباه لزيادة مدى البيانات للقائمة من التحقق من صحة البيانات انمنى اتى قدمت ما بقيد وما زال الباب مفتوحا لمفترحاتكم او ملاحظاتكم وكل عام وانتم بالف خير طريقة اخرى للبحث معدلة7.xlsb

وعليكم السلام ورحمة الله وبركاته ملفك لا بحتوى على اي كود تم عمل كود لطلبك والكود مرن يطبع الى اخر صف قيه بيانات Sub PrPAGES() Dim printWS As Worksheet Dim lastRow As Long Dim printRange As Range Set printWS = ThisWorkbook.Sheets("S1") lastRow = printWS.Cells(printWS.Rows.Count, "A").End(xlUp).Row Set printRange = printWS.Range("A1:C" & lastRow) printWS.PageSetup.PrintArea = printRange.Address printWS.PrintOut End Sub 1نموذج.xlsb

السلام عليكم ورحمة الله وبركاته عذرا لتأخرى في الرد حسب الصورة المرفقة مع ردكم الكريم اظافة عنصر فارغ في القائمة e5 وبناء عليه تكون b10&g10 فارغتان تم التعديل و يمكنك تعديل نطاق القائمة كما تشاء يمكنك الاسنغناء عن زر انقر هنا للبحث وإذا لاحظت أي شيء يحتاج تعديل أو عندك أي فكرة تحب نضيفها، أنا حاضر بأي وقت، لك كل الود والتقدير طريقة اخرى للبحث معدلة6.xlsb

وعليكم السلام ورحمة الله وبركاته اليك الكود المتاسب لطلبك Sub call1() Sheets("ff").Range("D3:U3").ClearContents Dim i As Integer For i = 1 To Sheets.Count Sheets("ff").Cells(3, 3 + i) = Sheets(i).Name Next i End Sub

السلام عليكم ورحمة الله وبركاته جرب التعديل التالى حسب طلبكم الاخير وفقكم الله طريقة اخرى للبحث معدلة5.xlsb

السلام عليكم ورحمة الله وبركاته

وعليكم السلام ورحمة الله وبركاته كمثال حساب1 =SUMIF($E$5:$E$1000; J5; $F$5:$F$1000) هي معادلة Excel تستخدم دالة SUMIF لجمع القيم بناءً على شرط معين تركيب الدالة SUMIF(range, criteria, [sum_range]) range: النطاق الذي يحتوي على القيم التي سيتم فحصها بناءً على الشرط. criteria: الشرط الذي يجب أن يتحقق لكي تتم عملية الجمع. sum_range: (اختياري) النطاق الذي سيتم جمع القيم منه إذا تحقق الشرط. شرح الدالة $E$5:$E$1000 → هذا هو نطاق الشرط: Excel سيبحث فيه عن القيم التي تساوي قيمة الخلية J5. J5 → هذا هو الشرط: نبحث عن الخلايا في العمود E التي تحتوي على نفس القيمة الموجودة في J5. $F$5:$F$1000 → هذا هو نطاق الجمع: إذا تم العثور على تطابق في العمود E، سيتم جمع القيمة المقابلة له في نفس الصف من العمود F. يوجد يديل اخر لها نفس النتيجة =SUMPRODUCT(($E$5:$E$1000=J5) * $F$5:$F$1000) ملاحظة / النطاق الى الصف 1000 يمكن زيادته او تقليله وجعلته 1000 حسب قولك ان العدد يمكن ان يكون اكثر اتمنى ان تجد ما يفيد في الشرح اعلاه لك كل التقدير والاحترام