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

وفيك بارك الله تم التعديل Private Sub ComboBox1_Change() On Error Resume Next Application.EnableEvents = False Sheets("Sheet2").Range("L8").value = ComboBox1.value TextBox12.value = Sheets("Sheet2").Range("L10").value Application.EnableEvents = True On Error GoTo 0 End Sub Private Sub TextBox12_Change() Static lastValue As Variant On Error Resume Next Application.EnableEvents = False If IsNumeric(Me.TextBox12.value) Then Dim value As Integer value = CInt(Me.TextBox12.value) Dim minValue As Integer, maxValue As Integer, newValue As Integer If value >= 8 Then minValue = 0 maxValue = 40 Else minValue = 0 maxValue = 30 End If Randomize Do newValue = Int((maxValue - minValue + 1) * Rnd()) + minValue Loop While newValue = lastValue Me.TextBox3.value = newValue lastValue = newValue ThisWorkbook.Sheets("Sheet2").Range("L13").value = newValue End If Application.EnableEvents = True On Error GoTo 0 End Sub if أوفيسنا 3.xlsb

الاجابة في المشاركة التالية

كود الذي قدمه استاذنا حسونة حسين كافٍ وأسرع ، لأنه: يمرّ على النطاق مرة واحدة فقط لتحديد الصفوف التي يجب إخفاؤها. يستخدم Union لتجميع الصفوف وإخفائها دفعة واحدة بدل إخفاء كل صف على حدة. يعيد أولًا إظهار جميع الصفوف ثم تخفي فقط الصفوف التي فيها صفر. بالنسبة للارقام العشرية هذا ملفك وهذا التنسيق كما قدمته انت وان كان لديك نتسيق معين ارجو توضيحه

وعليكم السلام ورحمة الله وبركاته يمكنك استخدام المعادلة نم اسخبها للاسفل =TEXT(D7;"dd/mm/yyyy") تحويل التاريخ الى نص.xlsx

السلام عليكم حسب فهمى لطلبك اليك الكود / اكتب القيمة في G2 Private Sub Worksheet_Calculate() Dim cell As Range Application.EnableEvents = False For Each cell In Me.Range("E6:E12") If cell.Value = 0 Then cell.EntireRow.Hidden = True Else cell.EntireRow.Hidden = False End If Next cell Application.EnableEvents = True End Sub 11.xlsb

وعليكم السلام ورخمة الله وبركاته جرب هذا الكود Sub MergeSheets_Total() Dim ws As Worksheet, wsTotal As Worksheet Dim i As Long, destRow As Long Dim dateValue As Variant Dim r As Long, lastDataRow As Long Dim sheetName As String On Error Resume Next Set wsTotal = ThisWorkbook.Sheets("TOTAL") On Error GoTo 0 If wsTotal Is Nothing Then MsgBox "لم يتم العثور على الشيت TOTAL", vbCritical Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False wsTotal.Range("A3:F320").ClearContents destRow = 3 For i = 1 To 31 sheetName = Format(i, "00") On Error Resume Next Set ws = ThisWorkbook.Sheets(sheetName) On Error GoTo 0 If Not ws Is Nothing Then lastDataRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastDataRow >= 4 Then dateValue = ws.Range("B1").Value For r = 4 To lastDataRow If Trim(ws.Cells(r, "A").Value) <> "" Then wsTotal.Cells(destRow, "B").Resize(1, 5).Value = ws.Cells(r, "A").Resize(1, 5).Value wsTotal.Cells(destRow, "A").Value = dateValue destRow = destRow + 1 End If Next r End If End If Set ws = Nothing Next i Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub The Safe1.xlsb

وعليكم السلام ورحمة الله وبركاته الكود يرتب حسب العمود H اولا ث ثم يرتب حسب العمود C Sub SortByColumn() Dim ws As Worksheet Dim rng As Range Dim lastRow As Long Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rng = ws.Range("A3:S" & lastRow) With ws.Sort .SortFields.Clear .SortFields.Add Key:=rng.Columns(8), Order:=xlAscending .SortFields.Add Key:=rng.Columns(3), Order:=xlAscending .SetRange rng .Header = xlNo .Apply End With End Sub اتمنى ان تجد فيه طلبك

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

اخي العزيز Foksh عذرا الملاحظتان كانت لصاحب الموضوع ولبست لكم استاذنا الفاضل فانتم اجبتم حسب طلب صاحب الموضوع وابدعتم والملاحظتان وخصوصا الثانية تبهت اليها صاحب الموضوع ان كان البحث لقصل واحد فملفه لا يحتاج الى شيئ وان كان البحث لاكثر من فصل فملفه يحتاج الى تعديل يمكنه طلب ذلك في موضوع جديد وحفيفة انا لست متخصص بل هاو للاكسل ويتقصنى الكثير لنعلمه وخصوصا ان دراستي بعيدة كل البعد عن البرمجة والحاسوب فتخصصى الفعلي هندسة معادن ومتخرج سنة 1983م وقتها لا يوجد حاسوب في مناهج الدراسة وتعلمت في هذه المدرسة مدرسة اوقيسنا ايام المبدع عبدالله باقشير وغيره من الاسابذة الافاضل اشتركت بالمنتدى 2011 ثم نسيت الايميل المشترك به ثم اشتركت من جديد يالمنتدى 2022 حاليا محال على المعاش لك ولكل اعضاء المنتدى كل التقدير والاخترام

السلام عليكم ورحمة الله بركاته مبدع دائما معلمنا 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