أبو حنــــين

مرحبا هل بهذه الطريقة 4444.rar

مرحبا هل جربت الملف الذي يحمل رقم 333 في مشاركتي الثانية

مبرو ك أخي سليم و نتمنى ان لا يثنيك هذا عن خرجاتك المتميزة في الدوال

فقط اريد أن ادلي بملاحظتين مهمتين 1 - كل ما كان الملف يحتوي على شرح مفصل للمطلوب و نموذ واضح للحل المراد الوصول اليه كلما اسرع الاخوة في الرد بدون تردد 2 - كلنا نتعلم و ربما المجيب عن السؤال يستفيد اكثر من السائل عنه لانه في هذه الحالة قد ارتقى بخطوة للامام و تعلم شيئا ربما لم يسبق له ان خاض فيه هل يستطيع أحدنا ان يختبر نفسه بطرح اسئلة على نفسه ثم يجيب عنها ؟ قطعا لا و لذلك دوما نتشوق الى الاسئلة التي تكون معالمها واضحة لنجيب و نفيد و نستفيد

السلام عليكم اخي احمد بعد إذن الأخ المحترم ياسر جرب هذا الكود ربما يفي بالغرض Sub sCopy() Application.ScreenUpdating = False Dim sh As Worksheet, MySheet As Worksheet, Ar Set sh = Sheets("اليومية") Ar = Array("يناير", "فبراير", "مارس", "ابريل", "مايو", "يونيو", "يوليو", "اغسطس", "سبتمبر", "اكتوبر", "نوفمبر", "ديسمبر") For i = 6 To sh.Range("B" & Rows.Count).End(xlUp).Row For x = 0 To 11 Set MySheet = Sheets(Ar(x)) If Format(sh.Cells(i, 2), "mmmm") = MySheet.Name Then LR = MySheet.Range("A" & Rows.Count).End(xlUp).Row + 1 sh.Range("A" & i).Resize(, 16).Copy MySheet.Range("A" & LR).PasteSpecial xlPasteValues End If Next Next Application.ScreenUpdating = True End Sub

جزاكم الله خيرا أخي ياسر و اخي جلال المرفق به إمكانية البحث بأكثر من معيار على السريع و ربما يحتوي على بعض الأخطاء 3333.rar

مرحبا عملت على الملف و نسيت ان ارفه الى المنتدى 2222.rar

اذا كان آخر صف في الجدول رقمه معلوم مثلا الجدول من الصف الخامس الى الصف 50 يكون الكود بالشكل التالي Sub DelRow() Application.ScreenUpdating = False For R = 50 To 5 Step -1 If Range("C" & R).Value = "" Then Range("C" & R & ":F" & R).Delete Shift:=xlUp Next Range("C5:F50").Borders.Value = 1 Application.ScreenUpdating = True End Sub

استعمل هذا الكود Sub DelRow() Application.ScreenUpdating = False For R = Cells(Rows.Count, 3).End(xlUp).Row To 5 Step -1 If Range("C" & R).Value = "" Then Range("C" & R & ":F" & R).Delete Shift:=xlUp Next Application.ScreenUpdating = True End Sub

السلام عليكم جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim sh As Worksheet If Target.Column = 9 And Target.Row > 14 Then Application.ScreenUpdating = False For Each sh In Sheets If IsNumeric(sh.Name) = True Then LR = sh.Cells(Rows.Count, "G").End(xlUp).Row ActiveCell.Offset(-1, 1).Value = ActiveCell.Offset(-1, 1).Value + WorksheetFunction.SumIf( _ sh.Range("G4:G" & LR), CStr(ActiveCell.Offset(-1).Value), sh.Range("I4:I" & LR)) ActiveCell.Offset(-1, 2).Value = ActiveCell.Offset(-1, 2).Value + WorksheetFunction.SumIf( _ sh.Range("G4:G" & LR), CStr(ActiveCell.Offset(-1).Value), sh.Range("J4:J" & LR)) ActiveCell.Offset(-1, 3).Value = ActiveCell.Offset(-1, 1).Value + ActiveCell.Offset(-1, 2).Value End If Next Application.ScreenUpdating = True End If End Sub

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

السلام عليكم أكتب التاريخ في مربع النص الأول و أضغط على أنتر الملف في الاسفل : الكود : Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If Not IsDate(TextBox1) = True Then TextBox1 = "": TextBox2 = "": TextBox3 = "" Else TextBox1.Value = Format(TextBox1, "dd-mm-yyyy") TextBox2.Value = Format(DateAdd("d", 180, CDate(TextBox1.Value)), "dd-mm-yyyy") TextBox3.Value = Format(DateAdd("d", 165, CDate(TextBox1.Value)), "dd-mm-yyyy") End If End Sub استعلام.rar

جزاك الله خيرا اخي ياسر و صدقني مازلت أتعثر في المصفوفات نوعا ما و كل مرة اكتشف خطوة

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

مر حبا جرب الكود التالي Sub iCopy() Dim sh As Worksheet, wr As Worksheet, j As Double, R As Double, Ary() Set sh = Sheets("ورقة1"): Set wr = Sheets("ورقة2") If wr.Range("a" & Rows.Count).End(xlUp).Row > 1 Then _ wr.Range("A2:E" & wr.Range("a" & Rows.Count).End(xlUp).Row) = "" With sh LsRow = .Range("a" & Rows.Count).End(xlUp).Row For j = 3 To LsRow If WorksheetFunction.CountIf(.Range("a3:a" & j), .Range("a" & j)) = 1 Then R = R + 1 ReDim Preserve Ary(1 To 5, 1 To R) Ary(1, R) = .Cells(j, 1): Ary(2, R) = .Cells(j, 2): Ary(3, R) = .Cells(j, 4) Ary(4, R) = WorksheetFunction.SumIf(.Range("a3:a" & LsRow), Ary(1, R), .Range("E3:E" & LsRow)) Ary(5, R) = Ary(3, R) * Ary(4, R) End If Next If R Then wr.Range("A2").Resize(R, 5).Value = WorksheetFunction.Transpose(Ary) End With wr.Select End Sub المرفق bb33.rar

السلام عليكم هم كثيرون حفظهم الله و أضيف عن ما ذكر سابقا - الدغيدي - بن عليه

استعمل هذا الكود Sub MyNmbr() Dim x As Integer, i As Integer x = 1 For i = 2 To Range("a1").Value * 3 Step 3 Cells(i, 3) = x x = x + 1 Next End Sub

بالفعل كان هناك خطأ كما أشار اليه اخي ياسر كود الحفظ سيصبح بهذا الشكل Private Sub CommandButton1_Click() Dim x As Byte, xx As Byte On Error GoTo 100 With Sheets(TextName.Text) Last = .Cells(Rows.Count, "H").End(xlUp).Row + 1 For x = 1 To 9 .Cells(Last, x).Value = Me.Controls("T" & x).Value Next For xx = 1 To 7 Me.Controls("T" & xx) = "" T1.SetFocus Next End With Exit Sub 100 MsgBox "The sheet " & TextName.Text & " does not exist", vbExclamation, "Error" End Sub أما في ما يخص البحث فيجب ان توضح المعيار هل سيكون عن طريق : Name , Mac , Ip , Rmac . . . . .

السلام عليكم هذه الملامح الاولى للبرنامج New AP 1.rar

العفو أخي أحمد

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

مرحبا اخي الاختصار يكون كالتالي =SUM(B3:B26)-SUM(A3:A26)

السلام عليكم جرب هذا الكود Private Sub CommandButton1_Click() Dim cel As Range, LR As Integer, x As Integer LR = ActiveSheet.UsedRange.Rows.Count x = 2 For Each cel In Range("A1:I" & LR) If IsEmpty(cel) = False Then Cells(x, 12) = cel.Value x = x + 1 End If Next cel End Sub

جزاك الله خيرا على هذا الكود الممتاز

المرفق Copy of Book1 ALRAQI2.rar