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

السلام عليكم ورحمة الله بارك الله فيك اخى الكريم ناصر

السلام عليكم ورحمة الله و فيك بركة اخى الكريم احمد شرفنى مرورك العطر

السلام عليكم ورحمة الله استبدل المعادلة المرفقة مع الملف بهذه المعادلة لا تنسى الضغط على Ctrl + Shift + Enter =IFERROR(LARGE(IF($D$4:$D$64=$F$4;$E$4:$E$64;"");ROW()-3);"")

السلام عليكم ورحمة الله استخدم هذا الكود Sub Date_To_Test() Dim wbDate As Workbook, wbTest As Workbook Dim Pat As String Dim LR As Long, LS As Long Application.ScreenUpdating = False Set wbTest = ThisWorkbook Pat = wbTest.Path & "\" Set wbDate = Workbooks.Open(Pat & "Data" & ".xlsb") Dim ws As Worksheet, Sh As Worksheet Set ws = wbDate.Sheets("add") Set Sh = wbTest.Sheets("add") LR = Sh.Range("B" & Rows.Count).End(xlUp).Row LS = ws.Range("B" & Rows.Count).End(xlUp).Row Sh.Range("B" & LR + 1).Resize(LS - 5, 115).Value = _ ws.Range("B6:DL" & LS).Value wbDate.Close False Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اليك الملف فقط اضغط على الزر اذا اردت ان يعمل معك الكود الى آخر صف حتى فى حالة عدم وجود بيانات بالعمود C قم بالغاء هذا السطر من الكود If C.Offset(0, 2) = "" Then Exit Sub الشرح هنا.rar

السلام عليكم ورحمة اللله استخدم هذا الكود Sub Purchses() Dim C As Range Dim x As Single, y As Single, z As Single Dim AA As String, xx As String, yy As String, zz As String AA = " مستمر بلا حركه" xx = "متحرك هذا الشهر": yy = "أول شهر بلا حركه": zz = "ثانى شهر بلا حركه" Application.ScreenUpdating = False For Each C In Sheet1.Range("A3:A805") x = WorksheetFunction.CountIf(Sheet1.Range("C3:C805"), C) y = WorksheetFunction.CountIf(Sheet1.Range("D3:D805"), C) z = WorksheetFunction.CountIf(Sheet1.Range("E3:E805"), C) If x > 0 Then C.Offset(0, 1) = xx ElseIf x = 0 And y > 0 Then C.Offset(0, 1) = yy ElseIf x = 0 And y = 0 And z > 0 Then C.Offset(0, 1) = zz ElseIf x = 0 And y = 0 And z = 0 Then C.Offset(0, 1) = AA End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله حل آخر بالمعادلات اذا لم تظهر معك النتيجة اضغط على ازرار (Ctrl+Shift+Enter) ثم اسحب نزولا جمع مواد الرسوب واظهار نتيجة الطالبة.rar

السلام عليكم ورحمة الله استخدم هذا الكود Sub Results() Dim ws As Worksheet, Sh As Worksheet Dim C As Range Dim LR As Long, p As Long Set ws = Sheets("Sheet1") LR = ws.Range("B" & Rows.Count).End(xlUp).Row For Each Sh In Worksheets If Sh.Name <> "Sheet1" Then Sh.Range("B11:C" & Sh.Range("B" & Rows.Count).End(xlUp).Row + 1).ClearContents End If For Each C In ws.Range("C11:C" & LR) If Trim(C.Value) = Trim(Sh.Name) Then p = p + 1 Sh.Cells(p + 10, "B") = C.Offset(0, -1).Value Sh.Cells(p + 10, "C") = C.Value End If Next p = 0 Next End Sub

السلام عليكم ورحمة الله اجعل الكود السابق كما يلى و لا تغيير فى الثانى Sub ShNames() Dim x As Integer x = Sheets.Count y = Sheets(x).Name For i = 2 To x If Sheets(i).Name <> "عملاء" Then Cells(i, 1) = i - 1 End If Cells(i, 2) = Sheets(i).Range("B2") Next End Sub

السلام عليكم ورحمة الله اكتب الكود الاول فى موديول عادى و الكود الثانى فى حدث الصفحة Sub ShNames() Dim x As Integer x = Sheets.Count - 1 y = Sheets(x).Name For i = 2 To x If Sheets(i).Name <> "عملاء" Then Cells(i + 1, 1) = i - 1 End If Cells(i + 1, 2) = Sheets(i).Range("B2") Next End Sub -------------------------------- Private Sub Worksheet_Activate() Call ShNames End Sub

السلام عليكم ورحمة الله اجعلها هكذا =MID(A1;LEN(A1)-8;9)

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF(D14*7%>130;130;IF(D14*7%<65;65;D14*7%))

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

السلام عليكم ورحمة الله استبدلها المعادلة التالية =IFERROR(SMALL($E10:$BA10;COUNTIF($E10:$BA10;"-")+1);"")

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

السلام عليكم ورحمة الله استخدم هذا الكود Sub AddRows() Dim x As Integer, i As Integer Application.ScreenUpdating = False x = Sheets("ورقة1").Range("D7") - 2 For i = 1 To x Sheets("ورقة1").Range("A13").EntireRow.Insert Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية "C5" ثم اسحب نزولا =IF(B5="";"";A5+B5-1)

السلام عليكم ورخمة الله استخدم هذا الكود Sub RentLate() Dim C As Range Dim ws As Worksheet, Sh As Worksheet Dim p As Long p = 5 Set ws = Sheets("المتأخرين") For Each Sh In Worksheets If Sh.Name <> "المتأخرين" Then For Each C In Sh.Range("D6:D" & Sh.Range("D" & Rows.Count).End(xlUp).Row) If C.Value = 0 Then p = p + 1 ws.Cells(p, 1) = p - 5 ws.Cells(p, 2) = C.Offset(0, 12) ws.Cells(p, 3) = C.Worksheet.Name End If Next End If Next End Sub

السلام عليكم ورحمة الله اضف هذا السطر قبل آخر Next ws.Range("C1").Value = ws.Name

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Sub AddSheets() Dim List As Range, C As Range Application.ScreenUpdating = False Set List = Sheet1.Range("B4:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row) On Error Resume Next For Each C In List If Len(Trim(C.Value)) > 0 Then If Len(Worksheets(C.Value).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value End If End If Next Dim Sh As Worksheet, ws As Worksheet Set Sh = Sheets("ahmed") Sh.UsedRange.Copy For Each ws In ThisWorkbook.Worksheets If ws.Name <> Sheets("Sheet1").Name Then ws.Range("A1").PasteSpecial xlPasteFormats ws.Range("A1").PasteSpecial xlPasteFormulas End If Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله ضع هذه الدالة " PtrSafe " بين كلمتى "Declare" و "Function" فى كل سطر تجد فيه هاتين الكلمتين

السلام عليكم ورحمة الله استخدم هذا الكود Sub AddSheets() Dim List As Range, C As Range Dim Sh As Worksheet Set List = Sheet1.Range("B4:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row) On Error Resume Next For Each C In List If Len(Trim(C.Value)) > 0 Then If Len(Worksheets(C.Value).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value End If End If Next End Sub

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