shreif mohamed

وعليكم السلام Sub sh24mar2018() Dim a, b As Long Dim aa, bb As Long Dim rng1, rng2 As Range a = Range("a" & Rows.Count).End(xlUp).Row b = Range("f" & Rows.Count).End(xlUp).Row For aa = 5 To a For bb = 5 To b If Cells(aa, 2) = Cells(bb, 7) Then If Cells(aa, 2) + Cells(aa, 3) + Cells(aa, 4) = _ Cells(bb, 7) + Cells(bb, 8) + Cells(bb, 9) Then Cells(bb, 7).Interior.Color = 194 Cells(aa, 2).Interior.Color = 194 End If End If Next Next Set rng1 = Range("a4", Range("a" & a)) Set rng1 = Range(rng1, rng1.End(xlToRight)) Set rng2 = Range("f4", Range("f" & b)) Set rng2 = Range(rng2, rng2.End(xlToRight)) rng1.Select Selection.AutoFilter Field:=2, Operator:=xlFilterNoFill Selection.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.AutoFilterMode = False Range("k4").PasteSpecial rng2.Select Selection.AutoFilter Field:=2, Operator:=xlFilterNoFill Selection.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.AutoFilterMode = False Range("p4").PasteSpecial rng1.Select Selection.AutoFilter Field:=2, Criteria1:=RGB(194, 0 _ , 0), Operator:=xlFilterCellColor Selection.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.AutoFilterMode = False Range("u4").PasteSpecial Rows("4:13").Select Application.CutCopyMode = False With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With End Sub

وعليكم السلام تفضل Private Sub CommandButton1_Click() Application.DisplayAlerts = False On Error Resume Next Sheets(1).Visible = True Dim iRow As Long Dim ws As Worksheet Set ws = Sheets(1) iRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row TextBox1.SetFocus MsgBox " هل تريد حفظ البيانات ", vbYesNo If vbYes Then ws.Cells(2, 2).Value = Me.TextBox1.Value ws.Cells(5, 3).Value = Me.TextBox2.Value ws.Cells(3, 4).Value = Me.TextBox3.Value Else TextBox1.SetFocus End If On Error GoTo 0 End Sub

السلام عليكم قم بوضع مسار الذي يتم حفظ الملفات بين الاقواس الملونة بالكود ادناه Sub PDFActiveSheet() Dim ws As Worksheet Dim strPath As String Dim myFile As Variant Dim strFile As String On Error GoTo errHandler Set ws = ActiveSheet strTime = Format(Now(), "yyyy-mm-dd") strFile = "E:\access\dox" & "\" & ws.Name & "_" & strTime & ".PDF" ws.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=strFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False, _ From:=1, _ To:=2 exitHandler: Exit Sub errHandler: MsgBox "Could not create PDF file" Resume exitHandler End Sub

السلام عليكم لنفرض ان الارقام تبدا من الخلية a1 نضع المعادلة التالية في b1 =IF(LEFT($A1,1)="5","966"&$A1,$A1)

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

السلام عليكم Sub sh22mar2018() Dim a, b, c, d As Long Dim e As Double Dim i As Long a = 16 ' عدد الصفوف المراد طباعتها في الصفحة الواحدة b = 1 ' بداية من الصف رقم c = 8 'عدد الاعمدة d = 100 ' اجمالي الصفوف في صفحة العمل e = Application.WorksheetFunction.RoundUp(d / a, 0) Range("A" & b, Range("A" & a)).Resize(, c).Select For i = 1 To e ActiveSheet.PageSetup.PrintArea = Selection.Address ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=False Selection.Offset(a).Select Next End Sub

عند ظهور الرساله اضغط debug ثم عدل الكود الاتي Private Sub CommandButton8_Click() DahyForm.Show End Sub الي Private Sub CommandButton8_Click() Me.Hide DahyForm.Show End Sub

عزرا اخي للتاخير المعادلات كما طلبت المعادلة الخاصة بترقيم معدل الدرجة بالنسبة لباقي الدرجات =RANK($C6,$C$6:$C$39) المعادلة الخاصة باسم التلميذ =IFERROR(INDEX(arhidden!$B:$B,MATCH(Feuil1!$P6,arhidden!$A:$A,0)),INDEX(resthidden!$B:$B,MATCH(Feuil1!$P6,resthidden!$A:$A,0))) لمعادلة الخاصة باللغة العربية =INDEX(arhidden!$D:$H,MATCH(Feuil1!$P6,arhidden!$A:$A,0),MATCH(Feuil1!J$5,arhidden!$D$1:$H$1,0)) المعادلة الخاصة بباقي المواد =SUMPRODUCT(--(J$4=resthidden!$E:$E)*--(Feuil1!$P6=resthidden!$A:$A),resthidden!$D:$D) بالنسبة لبيانات الخاصةبــ طالما ان البيانات متغير لا يمكن وضعها بشكل راسي مع ملف التجميع بالنسبة للمادة am يمكنني اضافتها ببساطة لباقي المواد وانتظر منك رد وعزرا مره اخري للتاخير لانشغالي ببعض الامور

،شكرا لكلماتك الطيبة ، وبارك الله فيك واسال الله ان يعلمنا ما ينفعنا قمت ببناء المعادلات بناء علي رقم التلميذ ومن المفترض ان لا يكون الرقم مكرر في مادة واحدة وسوف ارفق لك جميع المعادلات غدا ان شاء الله واذا كنت تريد اضافة المستوي والدورة والقسم والسنة الدراسية والمؤسسة واسم الاستاذ واي شي اخر فقط ابلغني وسوف اقوم بتعديل الماكرو لك بخصوص سؤال الشبكات ، عزرا لم افهم سؤالك جيدا اذا كنت تسال هل يمكن عمل ماكرو لجلب البيانات من الشبكة فهذا يتوقف علي اليه جلب البيانات من الاماكن المختلفة "مطلوب تفاصيل اكثر حول ذلك" الماكرو لديك مصمم للعمل عندما يكون الملفات للمواد الدراسية متواجدة جنب الي جنب مع ملف الماكرو في فولدر واحد في انتظار ردك اخي الكريم

يكون من الافضل ان يتم ارفاق الملف الذي يتم العمل عليه ان امكن او نموذج مبسط للمطلوب

وعليكم السلام ورحمه الله وبركاته Private Sub Worksheet_Change(ByVal Target As Range) Dim KeyCells As Range Set KeyCells = Range("A1:C19") If Not Application.Intersect(KeyCells, Range(Target.Address)) _ Is Nothing Then On Error GoTo son ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select Selection.Top = Target.Offset(0, 2).Top Selection.Left = Target.Offset(0, 9).Left Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = Target.Offset(0, 2).Height Selection.ShapeRange.Width = Target.Offset(0, 9).Width Target.Offset(1, 0).Select son: Exit Sub ' الكود الخاص بك End If End Sub

تفضل ياخي Book1.rar

وعليكم السلام و رحمة الله تعالى و بركاته لنفرض ان التاريخ موجود في الخلية b1 والعميل موجود في الخلية b2 تكن المعادلة =SUMPRODUCT(--($B$1=$B$7:$B$21)*--($B$2=$A$7:$A$21)*--($C$7:$C$21>0),$C$7:$C$21)

تفضل ياخي وعزرا للتاخير برجاء استخدام الشيت المرفق وعدم التعديل عليه او حذف اي شيء منه حيث ان الماكرو يعتمد علي اسماء الخلايا والشيتات المضافة يتم وضع الملف مع الملفات الاخري المارد تجميعها ثم فتح الشيت فقط والضغط علي ملئ البيانات ارجو من الله ان اكون وفقت grille hicham fard à imprimer.rar

وعليكم السلام اعمل عليه برجاء الانتظار للغد سوف اقوم بمشيئة الله بارفاق ملف لك فصبرا جميل

Sub deleterows() Dim i, j As Long i = Cells(Rows.Count, 7).End(xlUp).Row For j = i To 1 Step -1 If Cells(j, 7) = 1 Then Cells(j, 7).EntireRow.Delete End If Next End Sub

وعليكم السلام اذا افترضنا ان البينات لديك تقع في النطاق ِA1:A25 في الخلية b1 =MIN($A$1:$A$25) b2 =MIN(IF(LEFT($A$1:$A$25,2)*1>I5,LEFT($A$1:$A$25,2)*1))*10 with CTRL+Shift+Enter & Drag down c1=MAX(IF(-($A$1:$A$25)-$D4<10,$A$1:$A$25)) with CTRL+Shift+Enter & Drag down

وعليكم السلام ورحمه الله وبركاته Private Sub CommandButton1_Click() Dim a As Long Sheets("Data").Activate For a = 1 To CInt(TextBox5) Range("A" & Rows.Count).End(xlUp).Offset(1).Select Selection = TextBox1.Value Selection.Offset(, 1) = TextBox2.Value Selection.Offset(, 2) = TextBox3.Value Selection.Offset(, 3) = TextBox4 / TextBox5 Next End Sub

ثم رتب ابجدي بعد ذلك newsss.rar

وعليكم السلام من خلال قرائتي عن هذا الفيروس او ما يعرف بـــ ransomware فانه ينبغي عليك الرجوع للجهاز الموجود عليه الملف والذب اصيب بالفايروس ثم حذفه بالبرامج المتخصصة ثم بعد ذلك استخدام برنامج استرجاع جيد recovery وان شاء الله يرجع الملف لك والله اعلم

الاجهزة التي يعمل عليها الماكرو بكفائة هي التي تحمل نسخة حديثة للاوفيس " احدث من 2007 " وبالتالي لا سبيل الا محاولة تنصيب نسخة من الاوفيس تكون مماثلة لتلك التي تم بناء نموذجك عليها او احدث منه حيث ان هناك اشكال ورموز وسعة صفوف واعمدة تزداد مع صدور نسخة اوفيس جديدة وهو في الغالب مايسبب مشكلتك حاول ان تطلب من المتختصين تنصيب نسخة اوفيس حديثة " 2016 " سيعمل الملف معك ان شاء الله بدون مشاكل

تفضل ترحيل بيانات.rar

تفضل اخي الكريم ترحيل بيانات.rar

هل قمت بمحاولة حفظ الملف بشكل جديد بمعني عند الانتهاء وانت تريدحفظ الملف الان اذهب الي ملف ثم حفظ باسم ثم اختار المكان المناسب وبالاسم الذي تريده ثم اختار الامتداد الاتي xlsb ثم اضغط حفظ ايضا سؤوال اخر هل نسخة الاوفيس هي واحدة في الاجهزة التي يعمل بها والتي لا يعمل بها

تفضل ترحيل بيانات.rar