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

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

السلام عليكم ورحمة الله اخى الكريم اليك الملف لآظهار الفورم اضغط على (CTRL + Q ) و تكون لوحة المفاتيح باللغة الانجليزية أظهار الفورم عند الضغط على مفتاح معين من لوحة المفاتيح.rar

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF(AND($B2="سعودي";$C2>4);"غير محدد المدة";IF(AND($B2="سعودي";$C2=4;$D2>0);"غير محدد المدة";"محدد المدة"))

السلام عليكم ورحمة الله تفضل صافى الربح.rar

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول واريطه بالزر المرفق Sub Speaking() For i = 1 To 6 x = Cells(i, 1).Value Application.Speech.Speak x Next Application.Speech.Speak "Don" End Sub

السلام عليكم ورحمة الله تفضل اخى الكريم اختر الادارة من الخلية "L1" بالورقة الثانية المصنف1.rar

السلام عليكم ورحمة الله يمكنك استخدام هذا الكود Sub ClassFation() Dim C As Range, R As Integer For R = 2 To 9 For Each C In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) If C.Value <= Cells(R, "L") And C.Value >= Cells(R, "K") Then C.Offset(0, 1) = Cells(R, "J") End If Next Next End Sub

السلام عليكم ورحمة الله الحمد لله على تمام المطلوب اليك اخى شرح الكود Sub CallingData() Dim ws As Worksheet, sh As Worksheet الاعلان عن اسماء الشيتات التى سوف يتم التعامل معها Dim Arr As Variant, Temp As Variant 'الاعلان عن مصفوفتين احدهما هى المصدر و الاخرى للنتائج المطلوبة Dim i As Long, j As Long, p As Long 'الاعلان عن طول وعرض المصفوفة وعدد النتائج' Set ws = Sheets("ورقة1") Set sh = Sheets("ورقة2") 'التعريف بالشيت الاول والشيت الثانى' Arr = ws.Range("A13:O72").Value 'التعريف بالمصفوفة المصدر ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) 'التعريف بالمصفوفة الهدف وعلاقتها بالمصفوفة المصدر' For i = 1 To UBound(Arr, 1) طول المصفوفة المصدر' If Arr(i, 3) >= sh.Range("Q7") And Arr(i, 3) <= sh.Range("R7") Then 'الشرط الذى سوف يتم بناء عليه اختيار عناصر المصفوفة الهدف p = p + 1 'عد بيانات الشرط' For j = 1 To UBound(Arr, 2) 'عرض المصفوفة الهدف وهو هنا نفس عرض المصفوفة المصدر' Temp(p, j) = Arr(i, j) 'الاستكمال النهائى للمصفوفة الهدف' Next End If Next sh.Range("A11").Resize(p, UBound(Temp, 2)).Value = Temp 'ترحيل المصفوفة الهدف الى المكان المراد اظهار البيانات فيه' End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub CallingData() Dim ws As Worksheet, sh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Set ws = Sheets("ورقة1") Set sh = Sheets("ورقة2") Arr = ws.Range("A13:O72").Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 3) >= sh.Range("Q7") And Arr(i, 3) <= sh.Range("R7") Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next sh.Range("A11").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله اخى الكريم الكود السابق بعد تجريبه يقوم فعلا بجلب الكميات والاصناف فقط التى بها بيانات فقط والكود التالى لمسح الكميات التى تم كتابتها Sub Deleting() Dim ws As Worksheet, C As Range Set ws = Sheets("ورقة1") Application.ScreenUpdating = False ws.Range("C4:C33, G4:G33, K4:K33, O4:O33").ClearContents Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول و اربطه بزر عرض المرفق بالملف مع العلم انك لم تحدد اى الكميات التى تريد مسحها بعد تنفيذ الكود Sub Totals() Dim ws As Worksheet, C As Range Set ws = Sheets("ورقة1") Application.ScreenUpdating = False For Each C In ws.Range("B4:B33, F4:F33, J4:J33, N4:N33") If C.Offset(0, 1) <> "" And C.Offset(0, 2) <> "" Then C.Offset(0, 3) = C.Offset(0, 1) * C.Offset(0, 2) End If If C.Offset(0, 3) <> "" Then p = p + 1 Cells(p + 2, "T") = C.Value Cells(p + 2, "U") = C.Offset(0, 1) End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اخى الكريم محمد انسخ الكود التالى والصقه فى موديول جديد و اربطه بالزر المرفق بالملف Sub TrnsTime() Dim ws As Worksheet Dim R As Long Set ws = Sheets("ورقة1") For R = 7 To 1000 If ws.Cells(R, "A") = ws.Range("C2") And ws.Cells(R, "C") = ws.Range("D2") Then ws.Cells(R, "F") = ws.Range("E2") End If Next End Sub

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية "K3" ثم اسحب نزولا =LARGE(E3:J3;1)+LARGE(E3:J3;2)

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

السلام عليكم ورحمة الله تفضل مخازن 1.rar

السلام عليكم ورحمة الله ضع المعادلة التالية فى لبخلية "Q2" ثم اسحب =IF(AND(O2="";P2="");"لدى المصمم";IF(AND(O2<>"";P2="");"تصنيع";IF(AND(O2<>"";P2<>"");"انهاء التصنيع")))

السلام عليكم ورحمة الله انسخ الكودين التالين والصقهما فى الموديول واربط الكود الاول بالزر المتاح Option Explicit Sub Trdata_TwoCnds1() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, ii As Long, j As Long, jj As Long, P As Long, R As Long LR = Sheets("الرئيسية").Range("C" & Rows.Count).End(xlUp).Row Arr = Sheets("الرئيسية").Range("A8:AS" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 16) = "الاول" Then P = P + 1 For j = 1 To 9 Temp(P, j) = Arr(i, Choose(j, 1, 2, 3, 4, 5, 7, 23, 18, 45)) Next End If Next Sheets("شرط اول").Range("A8").Resize(P, UBound(Temp, 2)).Value = Temp Call Trdata_TwoCnds2 End Sub Sub Trdata_TwoCnds2() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, ii As Long, j As Long, P As Long, R As Long LR = Sheets("الرئيسية").Range("C" & Rows.Count).End(xlUp).Row Arr = Sheets("الرئيسية").Range("A8:AS" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 17) = "الثانى" Then R = R + 1 For j = 1 To 6 Temp(R, j) = Arr(i, Choose(j, 1, 2, 3, 4, 5, 18)) Next End If Next Sheets("شرط ثانى").Range("A8").Resize(R, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله تفضل مخازن.rar

السلام عليكم ورحمة الله اكتب المعادلة التالية فى الخلية "R2" ثم اسحب نزولا =IF(Q2="تصنيع ";TODAY();"")

السلام عليكم ورحمة الله جربى هذا الكود Sub uniqdata() Dim x As Long, LR As Long Dim R As Long, p As Long Application.ScreenUpdating = False LR = Range("B" & Rows.Count).End(xlUp).Row For R = 3 To LR x = WorksheetFunction.CountIf(Range("B3:B" & R), Range("B" & R)) If x = 1 Then p = p + 1 Cells(p + 3, 8) = Range("B" & R).Value End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الورقة المقصودة الحذر من الضغط على الخلية بدون قصد فيضيع مجهودك هدرا Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$1" Then Exit Sub If Target.Select Then Range("C2:C4").ClearContents End If End Sub

السلام عليكم ورحمة الله اضافة الى المعادالة الرائعة للاخ سليم اليك الكود التالى .... تأكد من تطابق الاسماء بشيت العملاء مع اسمائهم فى الفواتير Sub LastDate() Dim sh As Worksheet, x As String Dim LR As Long, p As Long, y As Date LR = Sheets("العملاء").Range("C" & Rows.Count).End(xlUp).Row + 5 For p = 6 To LR For Each sh In ThisWorkbook.Worksheets x = sh.Name If x <> "العملاء" Then If Sheets("العملاء").Range("C" & p) <> "" Then If sh.Range("H2").Value = Sheets("العملاء").Range("C" & p) Then y = WorksheetFunction.Max(sh.Range("C9:C1000")) Sheets("العملاء").Range("E" & p) = y End If End If End If Next Next End Sub

السلام عليكم ورحمة الله بارك الله فيك استاذ بن علية لقد استدركت الامر بعد تحميل الملف

السلام عليكم ورحمة الله بالضغط على زر الزيادة والنقصان ستتغير الاسماء فى الورقة المطلوبة اليك الملف الصف الرابع والخامس 2016-2017.rar

السلام عليكم ورحمة الله الكود التالى يفى بالغرض ولكنه سيستغرق وقتا طويلا عند التنفيذ Sub testcolo() Dim C As Range, x As Integer For Each C In ActiveSheet.UsedRange.Cells x = C.Interior.ColorIndex If x = 6 Then C.ClearContents End If Next End Sub