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

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

السلام عليكم ورحمة الله استخدم هذه المعادالة و لا تنسى الضغط على Ctrl+Shift+Enter =INDEX(الموقف!$B$2:$F$3;MATCH((E2&D2);الموقف!$B$2:$B$3&الموقف!$D$2:$D$3;0);5)

السلام عليكم ورحمة الله استخدم هذا الكود و قم بتغيير اسم ملف الصور الى Pics و اجعل ملف الاكسل خارج ملف الصور و ليس داخله Sub AddPics() Dim ws As Worksheet, C As Range Dim EmpName As String, T As String, Dpath As String Dim pic As Object Application.ScreenUpdating = False Set ws = Sheets("ورقة1") For Each pic In ws.Pictures pic.Delete Next pic On Error Resume Next Set C = ws.Range("B2:B5") EmpName = ws.Range("A5").Value Dpath = ActiveWorkbook.Path & "\" myDir = Dpath & "Pics" & "\" T = ".jpg" On Error Resume Next ws.Shapes.AddPicture Filename:=myDir & EmpName & T, _ linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=C.Left, _ Top:=C.Top, Width:=C.Width, Height:=C.Height Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اجعل الكود هكذا Sub Circles1() Dim C As Range Dim MyRng As Range, V As Shape Dim X As Integer, G As Integer, R As Integer, D As Integer '================================================ G = 2 ' عمود رقم الجلوس R = 13 ' صف الدرجات Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ X = ActiveWindow.Zoom Application.ScreenUpdating = False ActiveWindow.Zoom = 100 For Each C In MyRng If Cells(C.Row, G) = 0 Then GoTo 1 If C.Value = "" Then GoTo 1 On Error Resume Next If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) _ Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -3).Value < Cells(R, C.Column - 3) _ Or C.Offset(0, -3).Value Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.5 D = D + 1 End If 1 Next Set MyRng = Range("BV14:BV1013") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ For Each C In MyRng If Cells(C.Row, G) = 0 Then GoTo 2 If C.Value = "" Then GoTo 2 If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.5 D = D + 1 End If 2 Next Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ For Each C In MyRng If Cells(C.Row, G) = 0 Then GoTo 3 If C.Value = "" Then GoTo 3 If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.5 D = D + 1 End If 3 Next ActiveWindow.Zoom = X Application.ScreenUpdating = True MsgBox "تم إضافة " & D & " دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله" End Sub

السلام عليكم ورحمة الله الكود التالى سيجعل تغيير المسمى الوطيفى يتغير فى نفس الخلية حال انطبقت الشروط حتى لا يتم التغيير مرتين اذا تم الضعط على زر الماكرو مرة اخرى و بدون قصد انسخ الكود التالى و الصقه فى محرر الاكواد و خصص له زر Sub Update_Jopes() Dim sh As Worksheet Dim x As Date, y As Date, z As Date Dim p As Integer, i As Integer, Lr As Long Set sh = Sheets("السجل") Lr = sh.Range("B" & Rows.Count).End(xlUp).Row i = 2 Do While i <= Lr If IsDate(Range("D" & i)) Then x = Range("D" & i).Value y = Date p = Year(y) - Year(x) If p >= 4 Then z = DateAdd("yyyy", 4, x) sh.Cells(i, 3) = WorksheetFunction.VLookup(Cells(i, 3), _ Sheets("تغيير الدرجة").Range("A2:B27"), 2, 0) sh.Cells(i, 4) = z Else sh.Cells(i, 3) = sh.Cells(i, 3) sh.Cells(i, 4) = sh.Cells(i, 4) End If End If i = i + 1 Loop End Sub

السلام عليكم ورحمة الله تفضل اخفاء واظهار.xlsm

السلام عليكم ورحمة الله طبعا لا و لكن كما اخبرتك يوضع فى فى حدث thisworkbook و لمرة و احدة فقط و سيسرى هذا الكود على جميع الاوراق الحالية و اللاحقة

السلام عليكم ورحمة الله انسخ الكود التالى و الصقة فى حدث thisworkbook و غير اسم اسم الورقة الرئيسية "Main" فى الكود ذاته Private Sub Workbook_SheetActivate(ByVal Sh As Object) For Each Sh In ThisWorkbook.Worksheets If Sh.Name = "Main" Or Sh.Name = ActiveSheet.Name Then Sh.Visible = xlSheetVisible Else Sh.Visible = xlSheetHidden End If Next End Sub

السلام عليكم ورحمة الله بارك الله فيك اخى الكريم و لا شكر على واجب و الله فى عون العبد مادام العبد فى عون اخيه اذا حدث و اكتشفت اى عيوب فى الملف الرجاء فتح موضوع جديد حتى لا يتوه الموضوع بين الموضوعات بعد فترة من الزمن

السلام عليكم ورحمة الله استبدل الكودين السابقين بهذين الكودين و اخبرنى بالنتيجة الكود الاول : Sub ImpData() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, i As Long, j As Long, p As Long, x As Integer Set ws = Sheets("وارد") For Each C In ws.Range("B5:B10000") x = WorksheetFunction.CountIf(ws.Range("B5:B10000"), C.Value) For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "وارد" Or Sh.Name <> "منصرف" Then Arr = Sh.Range("A10:Q100").Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If x > 0 Then MsgBox "عفوا توجد بيانات قد تم ترحيلها من قبل سوف يتم الغاء العملية" Exit Sub Else If Arr(i, 2) <> "" Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, Choose(j, 2, 1, 17, 3, 13)) Next End If End If Next LR = ws.Range("C" & Rows.Count).End(xlUp).Row If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp p = 0 End If Next Next End Sub الكود الثانى : Sub ExpData() Range("A5:E1000").ClearContents Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant, x As Variant, C As Range Dim LR As Long, i As Long, j As Long, p As Long Set ws = Sheets("منصرف") For Each C In ws.Range("B5:B10000") x = WorksheetFunction.CountIf(ws.Range("B5:B10000"), C.Value) For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "وارد" Or Sh.Name <> "منصرف" Then Arr = Sh.Range("A10:Q100").Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If x > 0 Then MsgBox "عفوا توجد بيانات قد تم ترحيلها من قبل سوف يتم الغاء العملية" Exit Sub Else If Arr(i, 6) <> "" Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, Choose(j, 6, 5, 17, 9, 13)) Next End If End If Next LR = ws.Range("C" & Rows.Count).End(xlUp).Row If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp p = 0 End If Next Next End Sub

السلام عليكم ورحمة الله الكود الاول للوارد : Sub ImpData() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, i As Long, j As Long, p As Long, x As Integer Set ws = Sheets("وارد") For Each Sh In Sheets(Array("غيار رولة دهان كبيره ", "يد رولة دهان كبيره")) Arr = Sh.Range("A10:Q100").Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 2) <> "" Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, Choose(j, 2, 1, 17, 3, 13)) Next End If Next LR = ws.Range("C" & Rows.Count).End(xlUp).Row If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp p = 0 Next End Sub والكود الثانى للمنصرف : Sub ExpData() Range("A5:E1000").ClearContents Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, i As Long, j As Long, p As Long, x As Integer Set ws = Sheets("منصرف") For Each Sh In Sheets(Array("غيار رولة دهان كبيره ", "يد رولة دهان كبيره")) Arr = Sh.Range("A10:Q100").Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 6) <> "" Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, Choose(j, 6, 5, 17, 9, 13)) Next End If Next LR = ws.Range("C" & Rows.Count).End(xlUp).Row If p > 0 Then ws.Range("A" & LR + 1).Resize(p, 5).Value = Tmp p = 0 Next End Sub

السلام عليكم ورحمة الله تفضل ساجدة.xlsm

السلام عليكم ورحمة الله اضف هذا السطر قبل جملة For If ActiveSheet.name <> "mohsen" Or ActiveSheet.name <> "elshrok" Then Exit Sub

السلام عليكم ورحمة الله استخدمى هذه الاكواد الثلاثة Sub Get_Data() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim PatName As String Set ws = Sheets("تقرير بحالات الاعاقة") ws.Range("B5:I1000").ClearContents PatName = ws.Range("D2").Value Set Sh = Sheets("اعاقات خاصة") LR = Sh.Range("C" & Rows.Count).End(xlUp).Row Arr = Sh.Range("B3:I" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 4) = PatName Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) 'Temp(p, 1) = p Next End If Next If p > 0 Then ws.Range("B5").Resize(p, UBound(Temp, 2)).Value = Temp Call Get_Photo End Sub Sub Get_Photo() Application.ScreenUpdating = False Dim StudName As String, E As String, Dpath As String Dim pics As Object Dim Sh As Worksheet Dim C As Range, H Application.ScreenUpdating = False Set Sh = Sheets("تقرير بحالات الاعاقة") For Each pics In Sh.Pictures pics.Delete Next pics On Error Resume Next For Each C In Sh.Range("J5:J1000") StudName = C.Offset(0, -8).Value If C.Offset(0, -8).Value <> "" Then Dpath = ActiveWorkbook.Path myDir = Dpath & "\" & "صور" & "\" E = ".jpg" Sh.Shapes.AddPicture Filename:=myDir & StudName & E, _ linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=C.Left, _ Top:=C.Offset(0, 8).Top, Width:=C.Offset(0, 8).Width, Height:=C.Offset(0, 8).Height End If Next Application.ScreenUpdating = True End Sub Sub Delete2_Photos() Application.ScreenUpdating = False Dim pics As Object Dim ws As Worksheet Set ws = Sheets("تقرير بحالات الاعاقة") For Each pics In ws.Pictures pics.Delete Next pics Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله استخدم هذا الكود بدلا من الكود المدرج بالملف Sub settle2() Dim LR As Long LR = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row Range("K6:P6").Copy Sheets("Sheet1").Range("C" & LR + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله انسخ هذين الكودين وضعهما فى حدث ThisWorkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",true)" Application.DisplayFormulaBar = True ActiveWindow.DisplayHeadings = True Application.DisplayScrollBars = True Application.DisplayStatusBar = True End Sub Private Sub Workbook_Open() Application.ScreenUpdating = False Application.ExecuteExcel4Macro "show.toolbar(""ribbon"",false)" Application.DisplayFormulaBar = False ActiveWindow.DisplayHeadings = False Application.DisplayScrollBars = False Application.DisplayStatusBar = False Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اخى الكريم على بارك الله فيك و اشكرك على كلماتك الرقيقة و دعمك المستمر لجميع الاعضاء

السلام عليكم ورحمة الله تم بفضل الله تصحيح الخطأ Sub DatedIf_User() Dim ws As Worksheet, Sh As Worksheet, Mh As Worksheet Dim ShName As String, Rng As Range, C As Range Dim LR As Long, VlDate As Variant Application.ScreenUpdating = False Set ws = Sheets("ورقة1") VlDate = ws.Range("I5").Value '---------------------------------- LR = ws.Cells(Rows.Count, "E").End(xlUp).Row If LR < 8 Then Exit Sub ws.Range("I8:K" & LR + 1).ClearContents Set Rng = ws.Range("H8:H" & LR) '---------------------------------- If IsEmpty(VlDate) = True Then MsgBox "من فضلك ادخل تاريخ حساب السن" Exit Sub Else On Error Resume Next For Each C In Rng If C.Value <> "" Then YY = Year(VlDate) y = Year(C.Value) mm = Month(VlDate) m = Month(C.Value) dd = Day(VlDate) D = Day(C.Value) '----------------------- If D > dd And m > mm Then C.Offset(0, 1) = dd + 30 - D C.Offset(0, 2) = mm - m + 11 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D <= dd And m > mm Then C.Offset(0, 1) = dd - D C.Offset(0, 2) = mm - m + 12 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D > dd And m >= mm Then C.Offset(0, 1) = dd - D + 30 C.Offset(0, 2) = mm - m + 11 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D > dd And m < mm Then C.Offset(0, 1) = dd - D + 30 C.Offset(0, 2) = mm - m - 1 C.Offset(0, 3) = YY - y '----------------------- Else C.Offset(0, 1) = dd - D C.Offset(0, 2) = mm - m C.Offset(0, 3) = YY - y End If End If Next End If Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله الرجاء استبدال كود السرى بهذا الكود Sub SecNim() Dim R As Integer, S As Integer Application.ScreenUpdating = False Sheet4.Range("J8:J1000").ClearContents z = 0 For S = 7 To 16 For R = 8 To Sheet4.Range("C" & Rows.Count).End(xlUp).Row If Sheet4.Cells(R, "B") >= Cells(S, "E") And Sheet4.Cells(R, "B") <= Cells(S, "F") Then z = z + 1 Sheet4.Cells(R, "J") = Cells(S, "G") + z - 1 End If Next z = 0 Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله احبتى الكرام اعتذر عن خطأ حساب السن و قد تم تعديله بفضل الله الرجاء استبدال كود حساب السن بالملف بالكود التالى و سوف يتم اصلاح الترحيل و السرى بالمشاركة القادمة ان شاء الله تعالى Sub DatedIf_User() Dim ws As Worksheet, Sh As Worksheet, Mh As Worksheet Dim ShName As String, Rng As Range, C As Range Dim LR As Long, VlDate As Variant Application.ScreenUpdating = False Set ws = Sheets("بيانات الطالبات") VlDate = ws.Range("I5").Value '---------------------------------- LR = ws.Cells(Rows.Count, "E").End(xlUp).Row If LR < 8 Then Exit Sub ws.Range("I8:K" & LR + 1).ClearContents Set Rng = ws.Range("H8:H" & LR) '---------------------------------- If IsEmpty(VlDate) = True Then MsgBox "من فضلك ادخل تاريخ حساب السن" Exit Sub Else On Error Resume Next For Each C In Rng If C.Value <> "" Then YY = Year(VlDate) y = Year(C.Value) mm = Month(VlDate) m = Month(C.Value) dd = Day(VlDate) D = Day(C.Value) '----------------------- If D > dd And m > mm Then C.Offset(0, 1) = dd + 30 - D C.Offset(0, 2) = mm - m + 11 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D <= dd And m > mm Then C.Offset(0, 1) = dd - D C.Offset(0, 2) = mm - m + 12 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D >= dd And m = mm Then C.Offset(0, 1) = dd - D + 30 C.Offset(0, 2) = mm - m + 11 C.Offset(0, 3) = YY - y - 1 '----------------------- ElseIf D >= dd And m < mm Then C.Offset(0, 1) = dd - D + 30 C.Offset(0, 2) = mm - m - 1 C.Offset(0, 3) = YY - y '----------------------- Else C.Offset(0, 1) = dd - D C.Offset(0, 2) = mm - m C.Offset(0, 3) = YY - y End If End If Next End If Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله تم تعديل الملف بالاضافات المطلوبة يتبقى شئ واحد سوف يتم العمل عليه لاحقا يخص امتحان الدور الثانى سوف يتم ارساله لاحقا الملف الحالى يكفى للمرحلة الحالية اليك الملف اولى - ت.rar

السلام عليكم ورحمة الله الملف بعد اضافة الاكواد شيت درجات.xlsm

السلام عليكم ورحمة الله استخدم الكودين الاتيين الكود الاول لرسم الدوائر Sub Crl_Shp() ' دوائر مواد الرسوب Dim C As Range Dim MyRng As Range Dim LR As Long, i As Long, j As Long Application.ScreenUpdating = False LR = Range("B" & Rows.Count).End(xlUp).Row i = 10 Do While i <= LR Set MyRng = Range(Cells(i, 5), Cells(i, 23)) For Each C In MyRng If C.Value < Cells(9, C.Column).Value Or C.Value = "غ" Or C.Value = "" Then Set x = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left, C.Top, C.Width, C.Height) x.Fill.Visible = msoFalse x.Line.ForeColor.SchemeColor = 10 x.Line.Weight = 1.75 End If Next i = i + 1 Loop Application.ScreenUpdating = True End Sub الكود الثانى لمسح الدوائر عند اللزوم Sub RemovShp() ' مسح الدوائر Dim Shp As Shape For Each Shp In ActiveSheet.Shapes If Shp.AutoShapeType = msoShapeOval Then Shp.Delete Next Shp End Sub

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row < 9 Or Target.Column <> 4 Then Exit Sub Call Cases End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Cases() Dim j As Integer j = 9 Do While Cells(j, "D") <> "" If Cells(j, "D") = "حضور" Then Cells(j, "K") = 100 ElseIf Cells(j, "D") = "غياب" Then Cells(j, "K") = "غياب" ElseIf Cells(j, "D") = "اجازة" Then Cells(j, "K") = "اجازة" Else Cells(j, "K") = "" End If j = j + 1 Loop End Sub