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

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Sub suivie() Dim Sh As Worksheet, ws As Worksheet, C As Range Dim i As Long, p As Long Dim x, y, z Set Sh = Sheets("suivie") Sh.Range("A8:I" & Sh.Range("B" & Rows.Count).End(xlUp).Row).ClearContents x = Year(Sh.Range("B3")) y = Month(Sh.Range("B3")) z = Day(Sh.Range("B3")) For Each ws In ThisWorkbook.Worksheets If ws.Name <> "suivie" Then For Each C In ws.Range("F8:F" & ws.Range("F" & Rows.Count).End(xlUp).Row) If Year(C.Value) = x Then If Month(C.Value) = y Then If Day(C.Value) = z Then p = p + 1 Sh.Cells(p + 7, 1) = ws.Range("D5") For i = 0 To 7 Sh.Cells(p + 7, i + 2) = C.Offset(0, i) Next End If End If End If Next End If Next

السلام عليكم ورحمة الله استخدم هذا الكود Sub suivie2() Dim Sh As Worksheet, ws As Worksheet, C As Range Dim i As Long, p As Long Dim x, y, z Set Sh = Sheets("suivie") x = Year(Sh.Range("B3")) y = Month(Sh.Range("B3")) z = Day(Sh.Range("B3")) For Each ws In ThisWorkbook.Worksheets If ws.Name <> "suivie" Then For Each C In ws.Range("F8:F" & ws.Range("F" & Rows.Count).End(xlUp).Row) If Year(C.Value) = x Then If Month(C.Value) = y Then If Day(C.Value) = z Then p = p + 1 Sh.Cells(p + 7, 1) = ws.Range("D5") For i = 0 To 7 Sh.Cells(p + 7, i + 2) = C.Offset(0, i) Next End If End If End If Next End If Next End Sub

السلام عليكم ورحمة الله جرب هذا الكود Sub MSghin() Dim C As Range Dim x, y, z x = Range("G2") y = Range("F2") z = Range("H2") For Each C In Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row) If C.Value = x Then If C.Offset(0, 1) = y Then If C.Offset(0, 2) = z Then C.Offset(0, 7) = "M" End If End If End If Next End Sub

السلام عليكم ورحمة الله المعادلة الاول لايجاد اكبر قيمة =MAX(IF(Table5[الاسم]=[@الاسم];Table5[القيمة];"")) و المعادلة الثانية لايجاد اصغر قيمة =MIN(IF(Table5[الاسم]=[@الاسم];Table5[القيمة];"")) و لكى تعمل معك المعادلتين بدون خطأ اضغط على CTRL+SHIFT+ENTER لانها معادلات صفيف لا تظهر نتائجها بدون ذلك

السلام عليكم ورحمة الله اليك الكود بعد التعديل Sub الادخال() If [c1].Value <> "" And [a4].Value <> "" Then y = Trim([c1].Value) Sheets(1).Activate Range("a4 : g" & Cells(Rows.Count, "b").End(xlUp).Row).Copy Sheets(y).Activate ir = Sheets(y).Range("a" & Rows.Count).End(xlUp).Row MsgBox ir Sheets(y).Range("a" & ir + 1).Select Selection.PasteSpecial xlPasteValues Sheets(1).Select Range("a4:g100").ClearContents Range("c1").Select Else MsgBox ("يرجى التاكد من البيانات") End If Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله اجعل هذا السطر هكذا y = Trim([c1].Value)

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

السلام عليكم ورحمة الله استخدم الكود التالى Sub NatData() Dim C As Range, Sh As Worksheet Sheets("المطلوب").Range("E5:F" & Sheets("المطلوب").Range("E" & Rows.Count).End(xlUp).Row).ClearContents For Each Sh In Worksheets If Sh.Name <> "المطلوب" Then For Each C In Sh.Range("D3:D100") If C.Value Like "*" & "مصر" & "*" Then p = p + 1 Cells(p + 5, 5) = C.Offset(0, -1).Value Cells(p + 5, 6) = C.Value End If Next End If Next End Sub

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

السلام عليكم ورحمة الله استخدم هذا الكود Sub CallData() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long, x As Long Dim List As String, DataList As String Set ws = Sheets("BD") Set Sh = Sheets("نتيجة") List = Sh.Range("D1").Value DataList = Sh.Range("E1").Value If DataList = "" Then Exit Sub Sh.Range("A4:G" & Sh.Range("B" & Rows.Count).End(xlUp).Row + 3).ClearContents x = WorksheetFunction.Match(List, ws.Range("A1:G1"), 0) Arr = ws.Range("A2:G" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, x) = DataList Then p = p + 1 For j = 1 To 7 Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Sh.Range("A4").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله عفوا اخى الكريم وقع خطأ غير مقصود نتيجة لتسرعى استبدل الكود بالمشاركة السابقة بهذا الكود Private Sub ComboBox1_Change() Dim ws As Worksheet, wk As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, p As Long Set ws = Sheets("مخزن قطع الغيار") Set wk = Sheets("البحث باسم الصنف") Arr = ws.Range("E8:E" & ws.Range("E" & Rows.Count).End(xlUp).Row) ReDim Temp(1 To UBound(Arr, 1), 1 To 1) For i = 1 To UBound(Arr, 1) If Left(Arr(i, 1), Len(ComboBox1.Value)) = ComboBox1.Value Then p = p + 1 Temp(p, 1) = Arr(i, 1) End If Next ComboBox1.ListRows = p ComboBox1.List = Temp wk.Range("E10").Value = ComboBox1.Value End Sub

السلام عليكم ورحمة الله جرب هذا لعله ما تريد مخزن قطع الغيار.xls

السلام عليكم ورحمة الله لعدم وجود ملف دعنى اتخيل أن القيم موجودة بالعمود "C" و لعشرين صف متتالى ونريد ان ننسخ القيم التى بالصفوف الفردية ونلصقها متتالية فى العمود "D" حسب ما فهمت استخدم الكود التالى Sub trans() For i = 1 To 20 Step 2 If Cells(i, 3) <> "" Then p = p + 1 Cells(p, 4) = Cells(i, 3) End If Next End Sub

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول و خصص له زر Sub TransferData() Dim ws As Worksheet, Sht As Worksheet Dim Arr As Variant, Temp As Variant Dim i As Long, j As Long, p As Long Dim Nam As String, Trip As String Dim StrDate As Date, EnDate As Date Set ws = Sheets("from 01.12 till 15.12.2017") Set Sht = Sheets("Copy") Nam = ws.Range("I1") Trip = ws.Range("I2") StrDate = ws.Range("J1") EnDate = ws.Range("J2") ws.Range("A5:L" & ws.Range("E" & Rows.Count).End(xlUp).Row + 4).ClearContents Arr = Sht.Range("A2:AF" & Sht.Range("G" & Rows.Count).End(xlUp).Row).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 5) Like "*" & Trip & "*" And Arr(i, 6) >= StrDate And Arr(i, 6) <= EnDate And Arr(i, 7) Like "*" & Nam & "*" Then p = p + 1 For j = 1 To 12 Temp(p, j) = Arr(i, Choose(j, 1, 4, 5, 6, 7, 8, 9, 11, 12, 13, 15, 20)) Next End If Next If p > 0 Then ws.Range("A5").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية "E3" ثم اسحب نزولا =A3+B3&" " &D3

السلام عليكم ورحمة الله وبركاته الكود التالى للطباعة اربطه بالزر الموجود فى كل ورقة تريد طباعتها Sub Print_Invoice() ActiveSheet.PrintPreview y = ActiveSheet.[E2].Value z = MsgBox("هل حقا تريد طباعة الفاتورة رقم : " & y, vbYesNo) If z = vbYes Then ActiveSheet.PrintOut from:=1, to:=1, Copies:=1 Else Exit Sub End If End Sub اما السطرين التاليين ضعهم فى كل كود من الاكواد السابقة بعد كلمة Loop ws.Range("A7:E26").ClearContents x = x + 1 هذا وبالله التوفيق

السلام عليكم ورحمة الله انظر الى هذا الملف ربما هذا ما تقصده wsh.rar

السلام عليكم ورحمة الله استخدم الكود الآتى : Sub CountDays() Dim C As Range Dim Arr(), LR As Long, i As Long, p As Long Dim SDay As String Application.ScreenUpdating = False LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row SDay = "" i = 3 Do While i <= LR For Each C In Range(Cells(i, "B"), Cells(i, "AC")) If C.Value = "R" Then p = p + 1 ReDim Arr(i, p) Arr(i, p) = Cells(2, C.Column) SDay = SDay & Arr(i, p) & "+" Cells(i, "AD") = Mid(SDay, 1, Len(SDay) - 1) End If Next SDay = "" i = i + 1 Loop Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub hassan() Dim ws As Worksheet ActiveSheet.UsedRange.Copy x = Val(ActiveSheet.Name) + 1 Set ws = Sheets.Add(after:=Sheets(Sheets.Count)) ws.Name = x ws.Range("A1").PasteSpecial xlPasteValues Application.CutCopyMode = False ws.Range("A1").Select End Sub

السلام عليكم ورحمة الله استبدل هذا السطر فى الكود الثانى If shp.Type = msoShapeOval Then shp.Delete بهذا السطر If shp.Type = 1 Then shp.Delete

السلام عليكم ورحمة الله الكود الاول لعمل الدوائر ويخصص له زر و يتم ربطه به Sub Circles1() Call DeletingShp Dim ws As Worksheet, C As Range Dim MyRng As Range, V As Shape Dim G As Integer, R As Integer, D As Integer Application.ScreenUpdating = False Set ws = Sheets("شهادات الرابع") Set MyRng = ws.Range("B27:L27,B40:L40,B53:L53,B64:L64,B76:L76,B88:L88") For Each C In MyRng If C.Value = "دون المستوى" Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width, C.Height - 1) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.9 End If Next Application.ScreenUpdating = True End Sub اما الكود الثانى مخصص لمسح الدوائر وسيعمل تلقائيا مع الكود الاول Sub DeletingShp() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.Type = msoShapeOval Then shp.Delete Next shp End Sub هذا وبالله التوفيق

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

السلام عليكم ورحمة الله الكود الاول لاستحداث اوراق عمل جديدة حسب اسماء الفصول Sub AddNewSheets() Dim ws As Worksheet Dim ShList As Range Dim C As Range With Worksheets("رصد الدرجات") Set ShList = .Range("E6:E" & .Range("E" & .Rows.Count).End(xlUp).Row) End With On Error Resume Next For Each C In ShList If Len(Trim(C.Value)) > 0 Then If Len(Worksheets(C.Value).Name) = 0 Then Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value End If End If Next Call TrnsCls End Sub اما الكود الثانى هو مخصص لجلب بيانات الفصول Sub TrnsCls() Dim ws As Worksheet, Sh As Worksheet Dim R As Long Dim p As Long Application.ScreenUpdating = False p = 5 Set ws = Sheets("رصد الدرجات") For Each Sh In Worksheets For R = 6 To 204 If Trim(ws.Cells(R, 5).Value) = Trim(Sh.Name) Then p = p + 1 Sh.Range(Sh.Cells(p, 1), Sh.Cells(p, 104)).Value = ws.Range(ws.Cells(R, 1), ws.Cells(R, 104)).Value Sh.Cells(p, 1)=p-5 End If Next p = 5 Next Application.ScreenUpdating = True End Sub يخصص زر للكود الاول فقط لان الثانى يتم استدعاؤه من خلال الكود الاول التنسيق عليك ياصديقى هذا و بالله التوفيق

السلام عليكم ورحمة الله انسخ هذا الكود و الصقه فى موديول وخصص له زر Sub NumeicData() Application.ScreenUpdating = False For i = 4 To Range("N" & Rows.Count).End(xlUp).Row If Cells(i, "B") = "الإســـــــــم /" Then p = p + 1 Cells(i, "Q") = 1000 + p Else Cells(i, "Q") = "" End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله لا تترك اى مسافات بين هامش الخلية و بين علامة "=" اعد كتابة المعادله و ستصل الى النتيجة المرجوة باذن الله