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

السلام عليكم ورحمة الله استخدم هذا الكود Sub Transf() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, LS As Long, i As Long, j As Long, p As Long Set Sh = Sheets("BASS") LR = Sh.Range("B" & Rows.Count).End(3).Row Arr = Sh.Range("A5:E" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For Each ws In Worksheets LS = ws.Range("B" & Rows.Count).End(3).Row For i = 1 To UBound(Arr, 1) If Arr(i, 5) = ws.Name Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("A" & LS).Resize(p, UBound(Tmp, 2)).Value = Tmp p = 0 Next ws End Sub

السلام عليكم ورحمة الله ضع هذه المعادلة فى الخلية B6 ثم اسحب نزولا =IFERROR(INDEX(Sheet2!$A$5:$M$10000;MATCH($B$3;Sheet2!$A$5:$A$10000;0);ROW()-5);"")

السلام عليكم ورحمة الله استخدمى هذا الكود Sub CrNewSheets() Dim dic As Object, arr As Variant, Itm Dim i As Long, ws As Worksheet Set ws = Sheets("مخازن رقم 1") Set dic = CreateObject("scripting.dictionary") arr = ws.Range("J2:J" & ws.Range("J" & Rows.Count).End(3).Row).Value For i = 1 To UBound(arr) dic(arr(i, 1) & "") = "" Next On Error Resume Next ws.Range("A1:K1").Copy For Each Itm In dic.keys If Len(Trim(Itm)) > 0 Then If Len(Worksheets(Itm).Name) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = Itm Sheets(Itm).Range("A1").PasteSpecial xlPasteAll End If End If Next Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله استخدم الكود التالى بدلا من الكود السابق Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, LR As Long Set ws = Sheets("vi") Set Sh = Sheets("DATA") LR = Sh.Range("B" & Rows.Count).End(3).Row + 1 Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B" & LR).Resize(, 3) = Arr End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant Set ws = Sheets("vi") Set Sh = Sheets("DATA") Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B4").Resize(, 3) = Arr End Sub

السلام عليكم ورحمة الله فى هذا الجزء من المعادلة *(التحميل!$G$2:$G$1496=A10)* استبدل حرف G بحرف C لاتنسى الضغط على CTRL+ SHIFT+ENTER حت تعمل معك المعادلة بشكل جيد

السلام عليكم و رحمة الله اليك الملف مواد التخلف.xlsx

السلام عليكم و رحمة الله ضع المعادلة التالية فى الخلية "G8" ثم اسحب نزولا =VLOOKUP($F12;$B$2:$D$12;2;0) اما المعادلة التالية فضعها فى الخلية"H8" =IFERROR(INDEX($B$2:$D$12;SMALL(IF($B$2:$B$12=$F12;ROW($B$2:$B$12));COLUMN()-7)-1;3);"") ثم اضغط Ctrl+Shift+Enter ثم اسحب طولا وعرضا

السلام عليكم ورحمة الله اليك تعديل كود ترحيل الناجحين و الراسبين اذا شعرت ان تنفيذ الكود يستغرق وقتا طويلا يمكنك طلب عمل كود جديد يعتمد على المصفوفات و لكن لضيق الوقت قمت فقط بتعديل الكود المرفق بالملف اما باقى المطلوبات فى وقت لاحق ان شاء الله اليك الكود و يجب ربطه بزر لتنفيذه فى اى وقت Sub Tarheel() Dim R As Integer, M As Integer, N As Integer Sheets("ناجح").Range("A11:Q1012").Clear Sheets("دور ثانى").Range("A11:R1012").Clear M = 10: N = 10 Application.ScreenUpdating = False Application.DisplayAlerts = False For R = 11 To 1012 If Cells(R, 14) = "ناجح" Then M = M + 1 Range("A" & R).Range("A1:Q1").Copy With Sheets("ناجح") .Range("A" & M).PasteSpecial xlPasteValues .Range("A" & M).PasteSpecial xlPasteFormats .Range("A" & M).Value = M - 10 End With Application.CutCopyMode = False ElseIf Cells(R, 14) = "دور ثانى" Then N = N + 2 Range("A" & R).Range("A1:R1").Copy With Sheets("دور ثانى") .Range("A" & N).PasteSpecial xlPasteValues .Range("A" & N).PasteSpecial xlPasteFormats .Range("A" & N).Value = (N - 10) / 2 End With Application.CutCopyMode = False End If Next MsgBox (" بحمد الله تم ترحيل الناجحين والدور الثانى") Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub CallSude() Dim ws As Worksheet, Sh As Worksheet Dim i As Long, p As Long, j As Long Dim LR As Long, Fasl As String Application.ScreenUpdating = False Set ws = Sheets("laskat") For x = 3 To 58 Step 5 ws.Cells(x, 3).ClearContents ws.Cells(x + 1, 3).ClearContents ws.Cells(x + 1, 6).ClearContents ws.Cells(x + 2, 4).ClearContents ws.Cells(x, 12).ClearContents ws.Cells(x + 1, 12).ClearContents ws.Cells(x + 1, 15).ClearContents ws.Cells(x + 2, 13).ClearContents Next Fasl = ws.Range("S8").Text Set Sh = Sheets("data") LR = Sh.Range("C" & Rows.Count).End(3).Row For i = 3 To LR If Sh.Cells(i, 14) = Fasl Then p = p + 1 j = 2 Do While j <= 57 If ws.Cells(j, 8) = p Then ws.Cells(j + 1, 3) = Sh.Cells(i, 3) ws.Cells(j + 2, 3) = Sh.Cells(i, 15) ws.Cells(j + 2, 6) = Sh.Cells(i, 14) ws.Cells(j + 3, 4) = Sh.Cells(i, 5) ElseIf ws.Cells(j, 17) = p Then ws.Cells(j + 1, 12) = Sh.Cells(i, 3) ws.Cells(j + 2, 12) = Sh.Cells(i, 15) ws.Cells(j + 2, 15) = Sh.Cells(i, 14) ws.Cells(j + 3, 13) = Sh.Cells(i, 5) End If j = j + 5 Loop End If Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذه المعادلة =IF(LEFT($G2;2)="10";"ذكر";IF(LEFT($G2;2)="11";"أنثى";"رقم غير صحيح"))

السلام عليكم ورحمة الله الاخ ABOU ELSAAD يمكنك استخدام الكود التالى Sub AbsCount() Dim ws As Worksheet, LR As Long Dim x As Long Dim a As Integer, b As Integer, d As Integer Dim C As Range, Abst As String Const Com = "," Set ws = Sheets("SS") x = 3 LR = ws.Range("AG" & Rows.Count).End(xlUp).Row Do While x <= LR For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then a = WorksheetFunction.Min(ws.Range("A" & x & ":AE" & x)) b = WorksheetFunction.Max(ws.Range("A" & x & ":AE" & x)) ab = b - a + 1 d = WorksheetFunction.Count(ws.Range("A" & x & ":AE" & x)) If ab = d And d > 1 Then Abst = " يوم " & " (" & a & " - " & b & ")" ws.Range("AL" & x) = Abst Else Abst = C.Value & Com & Abst ws.Range("AL" & x) = Left(Abst, Len(Abst) - 1) End If End If Next C Abst = "" x = x + 1 Loop End Sub

السلام عليكم ورحمة الله استخدم الكود التالى Sub AbsCount() Dim ws As Worksheet, LR As Long Dim x As Long, y As Integer Dim C As Range, Abst As String Const Com = "," Set ws = Sheets("SS") x = 3 LR = ws.Range("AG" & Rows.Count).End(xlUp).Row Do While x <= LR For Each C In ws.Range("A" & x & ":AE" & x) If C.Value > 0 Then Abst = Abst & C.Value & Com ws.Range("AL" & x) = StrReverse(Left(Abst, Len(Abst) - 1)) End If Next C Abst = "" x = x + 1 Loop End Sub

السلام عليكم ورحمة الله جرب هذا الملف الرقم _القومى.xlsm

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية "C6" =IFERROR(INDEX(msheet!$D$5:$E$82;SMALL(IF(msheet!$D$5:$D$82=$E$3;ROW(msheet!$D$5:$D$82));ROW(A1))-4;2);"") ثم اصغط "CTRL+SHIFT+ENTER" ثم اسحب نزولا حتى الخلية "C35" ثم اكتب المعادلة التالية فى الخلية "E6" =IFERROR(INDEX(msheet!$D$5:$E$82;SMALL(IF(msheet!$D$5:$D$82=$E$3;ROW(msheet!$D$5:$D$82));ROW(A31))-4;2);"") و كر ر ما سبق

السلام عليكم ورحمة الله اليك الملف ابتدائي2020.xlsm

السلام عليكم ورحمة الله تم تعديل الكود Sub ALIDROOS_JC_T() Application.ScreenUpdating = False Dim sh As Worksheet, ws As Worksheet Set ws = Sheets("معلومات") On Error GoTo 0 For Each sh In ThisWorkbook.Worksheets For r = 2 To 102 If ws.Cells(r, 7).Value <> Empty Then If ws.Cells(r, 7).Value = sh.Name Then ws.Range(ws.Cells(r, 1), ws.Cells(r, 12)).Copy QQ = sh.Cells(1000, 1).End(xlUp).Row + 1 sh.Range("A" & QQ).PasteSpecial xlPasteValues End If End If Next Next MsgBox "تم الترحيل بنجاح" Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Work_Day() Dim ws As Worksheet, Sh As Worksheet Dim C As Range, LR As Long, i As Long Dim x As Integer, Dy As String Dim WF As Object Set ws = Sheets("ورقة2") Set Sh = Sheets("ورقة1") Set WF = WorksheetFunction LR = ws.Range("A" & Rows.Count).End(3).Row i = 2 Do While i <= LR For Each C In Sh.Range("A2:A" & ws.Range("A" & Rows.Count).End(3).Row) If ws.Cells(i, 1) = C.Value Then Dy = C.Offset(0, 1) x = WF.Match(Dy, ws.Range("B1:G1"), 0) ws.Cells(i, 1).Offset(0, x) = Dy End If Next i = i + 1 Loop End Sub

السلام عليكم ورحمة الله ضع هذه المعادلة فى الخلية "B" ثم اضغط Ctrl+Shift+Enter ثم اسحب عرضا وطولا =IFERROR(INDEX(ورقة1!$B$4:$E$8;SMALL(IF(ورقة1!$E$4:$E$8>0;ROW(ورقة1!$E$4:$E$8));ROW(A1))-3;COLUMN()-1);"")

السلام عليكم ورحمة الله استخدم الكود التالى الرقم السرى 123 يمكنك تغييره كما شئت Sub Delpics() Dim ws As Worksheet, Pic As Object Dim InBox As String InBox = InputBox(" يرجى ادخال كلمة السر", "ازالة الصور ") For Each ws In Worksheets For Each Pic In ws.Pictures If InBox = "123" Then Pic.Delete Else MsgBox "ارجو وضع الرقم السرى الصحيح ...حاول مرة ثانية" Exit Sub End If Next Next End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Delpics() Dim ws As Worksheet, Pic As Object For Each ws In Worksheets For Each Pic In ws.Pictures Pic.Delete Next Next End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub addpics() Dim ws As Worksheet For Each ws In Worksheets ws.Pictures.Insert ("D:\عنوان.jpg") Next End Sub

السلام عليكم ورحمة الله غير العبارة Dim ahmed As Range الى Dim ahmed As long و سيعمل معك الكود

السلام عليكم ورحمة الله ضع هذه المعادلة فى الخلية "B5" =IFERROR(INDEX('قائمة الموفين'!$B$5:$L$15;SMALL(IF('قائمة الموفين'!$M$5:$M$15=$H$2;ROW('قائمة الموفين'!$M$5:$M$15));ROW(A1))-4;COLUMN(A1));"") و اضغط Ctrl+Shift+Enter ثم اسحب طولا و عرضا ثم ضع المعادلة التالية فى الخلية "A5" ثم اسحب نزولا =IF(B5="";"";SUBTOTAL(3;$B$5:B5)) قوائم العمال1.xlsx

السلام عليكم ورحمة الله عمل طيب جعله الله فى ميزان حسناتك