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

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

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود وهو نفس الكود السابق بعد التعديل Sub KH_START1() Dim R As Integer ', i As Integer, n As Integer, s As Integer Dim Q As Range Dim sh As Worksheet: Set sh = Worksheets("add") Dim ws As Worksheet: Set ws = Worksheets("ArchiveS") Dim Lr As Long: Lr = sh.Cells(Rows.Count, "B").End(xlUp).Row Dim Ls As Long: Ls = ws.Cells(Rows.Count, "B").End(xlUp).Row m = 3 Application.ScreenUpdating = False For R = 6 To 506 If sh.Cells(R, "H") = "M" Then m = m + 1 sh.Range("A" & R).Range("A1:D1").Copy 'تحديد الاعمدة المراد نسخها' With ws 'هذا السطر لنسخ البيانات محتاج تعديل هذا السطر ليتم النسخ بعد اخر صف به بيانات ويترك البيانات السابقه ' ws.Range("A" & m + Ls - 3).PasteSpecial xlPasteValues ws.Range("A" & m + Ls - 3) = m + Ls - 6 'تسلسل' End With End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub PrintPages() Dim i As Integer, j As Integer i = Range("D3").Value j = Range("E3").Value If i < 1 Or j < 1 Then Exit Sub ActiveSheet.PrintOut from:=i, to:=j, Copies:=1 End Sub

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