ابراهيم الحداد

السلام عليكم و رحمة الله اتبع المسار الآتى : File - Options- Advanced Display option for this workbook ضع علامة صح امام Show sheet tabs

السلام عليكم ورحمة الله اجعل المعادلة هكذا =MATCH(H2;INDIRECT(P2);0)

السلام عليكم ورحمة الله ..استخدم الكود التالى Private Sub CommandButton1_Click() Dim x As Double, y As Double, p x = Me.TextBox1.Value Select Case x Case 1000 To 4999 p = 0.3 Case 5000 To 6999 p = 0.2 Case 7000 To 9999 p = 0.1 Case Is >= 10000 p = 0.05 End Select y = x * p Me.TextBox2.Value = y End Sub

السلام عليكم ورحمة الله فى هذا السطر Controls("TextBox" & j).Text = Cells(ListBox1.List(i, 1), j) تغيير بسيط جدا اجعله هكذا Controls("TextBox" & j).Text = Cells(ListBox1.List(i, 1), j+2) و تنتهى المشكلة

السلام عليكم و رحمة الله ..استخدم المعادلة التالية =IFERROR(INDEX($B$3:$C$20;SMALL(IF($B$3:$B$20=$F12;ROW($B$3:$B$20));COLUMN()-6)-2;2);"-") و لا تنسى الضغط على CTRL+SHIFT+ENTER قبل سحب المعادلة يسارا و لاسفل حتى تعمل معك بشكل جيد هذا و الله ولى التوفيق

السلام عليكم و رحمة الله جرب هذا الكود Sub ConTxtNum() Dim ws As Worksheet, C As Range Dim i As Long, j As Long Dim Arr, Tmp, Txt As String Set ws = Sheets("Sheet1") Application.ScreenUpdating = False For Each C In ws.Range("K6:K" & ws.Range("K" & Rows.Count).End(3).Row) For i = 1 To Len(C) Txt = Mid(C, i, 1) If Txt Like "[0-9]" Or Txt = "0" Then Arr = Arr & Txt Else Arr = Arr & " " End If Next Arr = Application.WorksheetFunction.Trim(Arr) Tmp = Split(Arr, " ") For j = 0 To UBound(Tmp) C.Offset(0, j + 2) = Tmp(j) Arr = "" Next Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله ..الارقام فى هذا السطر بالكود اجعلها هكذا Fsl = WorksheetFunction.Index(ws.Range("S8:T" & xx + 7), i, 1) يعنى 7 يتحول الى 8 و 6 يتحول الى 7

السلام عليكم ورحمة الله بالنسبة للزر الاول هو لعرض بيانات فصل محدد من القائمة المنسدلة دون طباعة اما الزر الثانى فهو مخصص لعرض الفصول بداية من الفصل الاول حتى الاخير و طباعته مباشرة ..الكود التالى لطباعة ورقة محددة بعد عرضها عن طريق الزر الاول Sub PrnData() ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False End Sub

السلام عليكم ورحمة الله اخى الكريم الكود يقوم بمسح البيانات حتى الصف رقم 49 ..سيتم رفع الملف بعد التعديلات لصعوبة تطبيقها بنفسك قوائم.xlsm

السلام عليكم و رحمة الله تم الغاء شرط العدد 40 سواء بالنسبة للذكور او الاناث و اصبح الشرط هو انتماء التلميذ للفصل و النوع فقط ..هذا و الله ولى التوفيق Sub AdClass() Const K1 = "ذكر": Const K2 = "أنثى" Dim Sh As Worksheet, ws As Worksheet Dim LR As Long, p As Long, q As Long Dim Fsl As String, C As Range Application.ScreenUpdating = False Set Sh = Sheets("بيانات"): Set ws = Sheets("فصول") ws.Range("D10:I49") = "": ws.Range("K10:P49") = "" LR = Sh.Range("E" & Rows.Count).End(3).Row Fsl = ws.Range("O7").Value For Each C In Sh.Range("J10:J" & LR) If C.Value = Fsl And C.Offset(0, -3) = K1 Then p = p + 1 ws.Range("D" & p + 9).Resize(, 6).Value = Sh.Range("D" & C.Row).Resize(, 6).Value ElseIf C.Value = Fsl And C.Offset(0, -3) = K2 Then q = q + 1 ws.Range("K" & q + 9).Resize(, 6).Value = Sh.Range("D" & C.Row).Resize(, 6).Value End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اخى الكريم جرب هذا الكود ..لو لك طلبات غير و اضحة فى مشاركتك الاولى يرجى توضيحها لآن الملف البببانات فيه غير كافية سواء من ناحية عدد الفصل الواحد او النوع بحيث نتمكن من اختبار الكود جيدا ..ارجو الاجابة بوضوح بعد التجربة ..اليك الكود Sub AdClass() Const K1 = "ذكر": Const K2 = "" Dim Sh As Worksheet, ws As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, p As Long, i As Long, ii As Long, j As Long Dim Fsl As String, C As Range Application.ScreenUpdating = False Set Sh = Sheets("بيانات"): Set ws = Sheets("فصول") ws.Range("D10:I49") = "": ws.Range("K10:P49") = "" LR = Sh.Range("E" & Rows.Count).End(3).Row Fsl = ws.Range("O7").Value For Each C In Sh.Range("J10:J" & LR) If C.Value = Fsl Then p = p + 1 If p <= 40 Then On Error Resume Next ws.Range("D" & p + 9).Resize(, 6).Value = Sh.Range("D" & C.Row).Resize(, 6).Value Else ws.Range("K" & p - 31).Resize(, 6).Value = Sh.Range("D" & C.Row + 40).Resize(, 6).Value End If End If Next Application.ScreenUpdating =true End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub SeaechData() Dim Sh As Worksheet, ws As Worksheet Dim LR As Long, i As Long, C As Range Dim ShNam As String Set Sh = Sheets("ورقة11") For Each ws In Worksheets If ws.Name <> Sh.Name Then LR = ws.Range("A" & Rows.Count).End(3).Row i = 7 Do While Sh.Cells(i, 6) <> "" For Each C In ws.Range("A1:A" & LR) If C.Value = Sh.Cells(i, 6) Then ShNam = ws.Name Sh.Cells(i, 7) = ShNam End If Next i = i + 1 Loop End If Next End Sub

السلام عليكم ورحمة الله ..استبدل هذه العبارة MsgBox .Cells(r, 1) بهذه العبارة x = x & Chr(10) & .Cells(r, 1) و امسح هذه العبارة MsgBox .Cells(r, 1) و قم باولة العلامة من امام هذه العبارة MsgBox x

السلام عليكم و رحمة الله اخى الكريم هى نفس المشكلة فى كل الاكواد لابد من تحديد اسم الشيت الذى تستمد منه البيانات فى الماكرو المسمى FILTERAR_CRITERIO اجعل هذا السطر Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = Range("A" & Z).Value هكذا Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = Sheet1.Range("A" & Z).Value و كذلك كل الاسطر التالية و المشابهة له و سيعمل معك الكود بمنتهى الكفاءة

السلام عليكم و رحمة الله ..فى كود الفلترة حول هذه الكلمة ActiveSheet الى Sheet1..و ينتهى الامر باذن الله

السلام عليكم ورحمة الله فى الكود المسمى Public Sub cargar_cambobox ... استبدل هذه العبارة Me.ComboBox1.RowSource = Range("k1:k12").Address بتلك العبارة Me.ComboBox1.List = Sheet1.Range("k1:k12").Value

السلام عليكم و رحمة الله اجعل الكود هكذا Sub y() Dim sumRange As Range, criteriaRange As Range Dim result As Double Dim i As Integer Dim lastrow As Long Dim R As Range Dim criteria As Variant Set criteriaRange = Range("D4:D20") criteria = Array("اجمالي صنف1", "اجمالي صنف2") j = 1 Do While j <= 6 Set sumRange = Range("E4:E20").Offset(0, j - 1) For i = 0 To UBound(criteria) result = WorksheetFunction.Sum(result, WorksheetFunction.SumIfs(sumRange, criteriaRange, criteria(i))) Set R = ActiveSheet.Cells.Find("اجمالي الأصناف", , xlValues, xlWhole) If Not R Is Nothing Then R.Select ActiveCell.Offset(0, j).Select ActiveCell.Value = result Next i result = 0 j = j + 1 Loop Range("D3").Activate End Sub

السلام عليكم و رحمة الله استخدم الاكواد الآتية كلها انسخها و ضعها كما هى Private Sub CommandButton5_Click() Dim ws As Worksheet, C As Range Set ws = Sheets("Sheet1") For Each C In ws.Range("C2:C" & ws.Range("C" & Rows.Count).End(3).Row) If C.Value = Val(Me.TextBox2.Value) Then C.Offset(0, 1).Value = Me.TextBox3.Value End If Next End Sub Private Sub CommandButton6_Click() Unload Me End Sub Private Sub TextBox2_Change() If Len(Me.TextBox2.Value) <> 14 Then Exit Sub Dim a As Single, b As Single, C As Single Dim m As Single, n As Single, cd, sn cd = Val(Me.TextBox2.Value) m = Left(cd, 1) If m = 2 Then n = 19 Else n = 20 End If a = Mid(cd, 2, 2) b = Mid(cd, 4, 2) C = Mid(cd, 6, 2) sn = n & a & "/" & b & "/" & C Me.TextBox3.Value = sn End Sub

السلام عليكم و رحمة الله عذرا اخى الكريم / الجمال لم انتبه لموضوعك هذا عنى الا من ايام قليلة و انا لم اعتد فى منتدى اوفيسنا الا الدخول على قسم الاكسل و بالصدفة و انا ابحث عن عودة عضويتى الضائعة فى المنتدى وجد هذا الموضوع الخاص بى . صراحة استحيت من الرد و خاصة و قد مرت ما يقرب من الثلاثة شهور على هذا الموضوع و لكن اليوم ذكرتنى ادارة المنتدى بهذا الموضوع فلم اجد بدا من الرد حقيقة اخى / الجمال يشرفنى معرفتك و خدمتك فى اى امر تريد و لكن من خلال المنتدى و من قسم الاكسل تحديدا و الخقيقة كثير من الاعضاء سواء فى هذا المنتدى او بعض المنتديات الاخرى طلبوا الاتصال بى او عمل صداقة و كثيرا ما اعتذر لهم . بصراحة لا عمرى و لاخبرتى فى البرمجة تسمح لى بأن اعشم احدا ان اقدم لهم خدمات او عمل صداقات او اتصالات الا من خلال هذا المنتدى العظيم و بيتنا الكبير الذى يجمعنا دائما اعتذر ان كان ردى هذا فيه ما يحبط اى شخص يرى فىٌ غير ذلك هذا و الله ولى التوفيق اخيك / ابراهيم الحداد

السلام عليكم ورحمة الله استخدم المعادلة التالية =OFFSET(البيانات!$A$2;COUNT(البيانات!$A:$A)-1;0)

السلام عليكم و رحمة الله لا اعلم ان كانت المشكلة من التنسيق او وجود بيانات مخفية تجعل البيانات ترحل بعد الصف 387 لتتأكد بنفسك انزل الى الصف 387 و سوف ترى البيانات التى تم ترحيلها لكى يعمل معك الكود بدون مشاكل ..حدد النطاق من B8 الى مثلا G400 مثلا ثم اضغط على زر Delete ليتم مسحها و ينتهى الامر ..ثم اضعط زر الترحيل سترى البيانات و قد رحلت ..هذا و الله ولى التوفيق

السلام عليكم و رحمة الله اتمنى ان يكون هذا ما تصبو اليه Sub try01() Dim r, r2, x, l As Long Dim ws As Worksheet ' [هذه العبارة تم اضافتها حتى يعمل معك الكود من اى ورقة Set ws = Sheets("summare ") ' اسم الورقة التى سوف يتم العمل عليها ws.Range("b7:o1000") = "" ' محو البيانات القديمة x = ThisWorkbook.Sheets.Count ' عدد الشيتات فى الملف r = 7 ' الصف الذى سوف يبدأالعمل من خلاله For i = 3 To x ' ترتيب الشيتات التى سوف يتم استيراد البيانات منها 'اسم الشيت ws.Cells(r, "b") = Sheets(i).Name ' اسماء الشيتات تسجل فى هذا العمود ws.Cells(r, "c") = Sheets(i).Range("c8") ' رقم العقد و الموجود فى هذه الخلية من الشيتات المشار اليها ' عدد الصفوف بالشيت Z = Sheets(i).Cells(Rows.Count, "b").End(xlUp).Row ' آخر صف فى هذا العمود For i2 = 12 To Z ' البداية من الصف 12 حتى الصف 'التاريخ dt = Sheets(i).Cells(i2, "b") ' الاعمدة التى تحتوى على التواريخ التى سيتم جلب البيانات منها For i3 = 4 To 15 ' الاعمدة التى سوف يتم جلب البيانات اليها If Month(ws.Cells(6, i3)) = Month(dt) And Year(ws.Cells(6, i3)) = Year(dt) Then ' شرط استدعاء البيانات ws.Cells(r, i3) = Sheets(i).Cells(i2, "f") + ws.Cells(r, i3) ' الامر بأضافة البيانات End If Next i3 Next i2 r = r + 1 Next i End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub SSheet() Dim ws As Worksheet, Data As Worksheet, ShName As String Dim LR As Long, ER As Long, x As Integer Set Data = Sheets("Sheet1") ShName = Data.Range("C3").Text ER = Data.Range("B" & Rows.Count).End(3).Row x = ER - 7 For Each ws In Worksheets If ws.Name = ShName Then LR = ws.Range("B" & Rows.Count).End(3).Row ws.Name = ShName ws.Range("B" & LR + 1).Resize(x, 5) = Data.Range("B8").Resize(x, 5).Value End If Next End Sub

السلام عليكم و رحمة الله لكى يعمل معك الكود التالى لابد من تطابق البيانات التى فى العمود AP مع رؤوس الاعمدة فى الصف الثالث يمكنك مراجعة ذلك باستخدام علامة = بين الخلية فى الصف الثالث و الخلية فى العمود AP اليك الكود Sub TData() Dim ws As Worksheet, LR As Long Dim C As Range, i As Long Dim x As Integer, y As Double Set ws = Sheets("الايرادات") LR = ws.Range("AP" & Rows.Count).End(3).Row i = 5 Do While i <= LR For Each C In ws.Range("B3:AL3") If ws.Range("AP" & i).Value = C.Value Then x = C.Column + 1 y = ws.Cells(i, x).Value ws.Range("AO" & i).Value = y End If Next i = i + 1 Loop End Sub

السلام عليكم و رحمة الله بارك الله فيك اخى الكريم / حسونة لن انسى انك اول من علق على هذه الشكوى و اول من افتتح بابا لحل المشكلة جعلها الله فى ميزان حسناتك