احمد عبد الناصر

السلام عليكم
 
جرب هذا الكود
 
Sub dahmour() Application.ScreenUpdating = False With Sheets(1) .Select .AutoFilterMode = False lastrow = Range("a" & Rows.Count).End(xlUp).Row .Range("A1:D" & lastrow).AutoFilter .Range("A1:D" & lastrow).AutoFilter Field:=4, Criteria1:="ناجح" .Range("a2:d" & lastrow).Copy Sheets(2).Range("a1") .AutoFilterMode = False End With ''''''''''''''''''''''''''''''' With Sheets(2) .Select x = 1 Do Sheets(1).Range("a1:d1").Copy .Range("a" & x & ":d" & x).Insert Shift:=xlDown x = x + 21 Rows(x & ":" & x + 3).Insert Shift:=xlDown Cells(x + 3, 3) = "=SUM(R[-24]C:R[-1]C)" x = x + 4 If IsEmpty(Cells(x, 2)) Then Exit Do Loop End With '88888888888888888888888888888888888888888888888888888888 With Sheets(1) .Select .AutoFilterMode = False lastrow = Range("a" & Rows.Count).End(xlUp).Row .Range("A1:D" & lastrow).AutoFilter .Range("A1:D" & lastrow).AutoFilter Field:=4, Criteria1:="راسب" .Range("a2:d" & lastrow).Copy Sheets(2).Range("a" & x) .AutoFilterMode = False End With ''''''''''''''''''''''''''''''' With Sheets(2) .Select r = x Do Sheets(1).Range("a1:d1").Copy .Range("a" & r & ":d" & r).Insert Shift:=xlDown r = r + 21 Rows(r & ":" & r + 3).Insert Shift:=xlDown Cells(r + 3, 3) = "=SUM(R[-24]C:R[-1]C)" r = r + 4 If IsEmpty(Cells(r, 2)) Then Exit Do Loop End With Application.CutCopyMode = False ''''''''''''''''''''''''''''''' Application.ScreenUpdating = True End Sub  
 
تحياتي

السلام عليكم
 
اسعد الله اوقاتكم
 
اعتقد الاكسيل متعرف عليه كتاريخ هجري و لكن عند الفرز يعامله معاملة النص , ليس لي تعامل مع التواريخ الهجرية في الاكسيل صراحة .
 
جرب المرفق 
 
-تاريخ معدل1 لان بعض التواريخ فيها مسافة كهذه " 11/10/1432"  .
-تاريخ معدل2 ليغير اتجاه التاريخ (او النص حسب رؤية اكسيل) , و هذا الذي سوف ترتب علي حسبه وهو العمود   i .
-هذه الطريقة تنفع ما دامت التواريخ بنفس عدد الخانات كما بملفك المرفق  مثلا "11/09/1431"  و ليس  "11/9/1431"
 
تحياتي
تصفية حسب الاقدم بالتاريخ+.rar

السلام عليكم
 
جرب هذه 
Private Sub UserForm_Initialize() With ComboBox1 .ColumnCount = 2 .ColumnWidths = "100;100" .ColumnHeads = True endrow = Sheets("list").Range("A1").End(xlDown).Row '.AddItem Sheets("list").Range("A" & endrow, ("B1")) Data = "=list!a2:b" & endrow .RowSource = Data End With End Sub تحياتي

السلام عليكم
 
-هناك قيم تحتاج round مثل القيمة 89.5% في الخلية b2
-هناك كلمات بها مسافات زيادة تحتاج لازلة هذه المسافات هكذا " منتظمة" تصبح "منتظمة"
 
لست متأكد من اني فهمت الجزء الثاني من هذه الجملة
----
لو بقى الفرق بين المدة المنقضية والمنجز اقل من او يساوي 20 % او المنجز يتخطي المدة المنقضية اذا  يتم التحويل الى منتظمه
----
 
جرب المرفق
 
تحياتي
help+.rar

.
Error+.rar

السلام عليكم
=IF(C7="";"";SUMIFS(Sheet1!$J$3:$J$10000;Sheet1!$C$3:$C$10000;$D$3;Sheet1!$E$3:$E$10000;C7;Sheet1!K3:K10000;$D$4)) جرب ثبت الجزء الاخير من المعادلة (Sheet1!K3:K10000) مثل بقية المعادلة في الخلية D7 لتصبح
=IF(C7="";"";SUMIFS(Sheet1!$J$3:$J$10000;Sheet1!$C$3:$C$10000;$D$3;Sheet1!$E$3:$E$10000;C7;Sheet1!$K$3:$K$10000;$D$4)) تحياتي

السلام عليكم
 
حل اخر
=CEILING((IF((SUM(B5:G5)<=$K$8);$K$5;($K$5-((SUM(B5:G5)+SUM(SUMIF(B5:G5;{"a";"n"};$B$2:$G$2)))*$K$7))));0.25) تحياتي
المصنف1++.rar

السلام عليكم
 
جرب هذه 
 
بعض التقدريات غير متشابهة مثلا (جيد) و (جيد ) بعدها مسافة لذلك قمت باضافة دالة trim 
 
تحياتي
المقارنة#+.rar

السلام عليكم
 
جرب هذه
 
ملاحظة : الكود به خطأ عند اختيار خلايا بدل من نطاقات
 
تحياتي
رسم بيانى بالضغط على الزر++.rar

السلام عليكم
 
اسعد الله صباحكم
 
جرب هذا 
M = M + 1 xm = xm + 1 If xm = 16 Then M = M + 1 xm = 1 End If تحياتي
mohammed+.rar

السلام عليكم 
 
جرب هذا التعديل 
 
sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.Path & "\" & [b1] & ".accdb;Persist Security Info=True "
 
تحياتي

السلام عليكم
 
جرب  هذه 
 
 
تحياتي
1 - Copy+.rar

السلام عليكم
 
جرب هذه 
=A2&" "&A3 تحياتي

السلام عليكم
 
جرب هذه 
 
ملاحظة : الكود يعمل عند كتابة المبيعات في العمود C .
 
اعتقد ان لا حاجة لاستخدام الاكواد و الافضل كان استخدام المعدلات .
 
تحياتي
+المصنف2010.rar

السلام عليكم
 
الاستاذ و الاخ عباس تحياتي لك
 
جرب هذه 
Sub Dahmour() Application.ScreenUpdating = False Dim Target As Range For g = 1 To Range("iv1").End(xlToLeft).Column Set Target = Cells(1, g) l = Target.Offset(10000, 0).End(xlUp).Row Add = Target.Resize(l, 1).Address add2 = Range("Ca1:ca" & l).Address Range(Add).Copy Range(add2) For Each c In Range(add2) c.Offset(0, 1) = c.Interior.ColorIndex Next Range("Ca2:cb" & l).Sort key1:=Range("cb2"), order1:=xlDescending Range("Ca2:ca" & l).Copy Target.Offset(1, 0) Range("Ca1:cb" & l).Clear Next Application.ScreenUpdating = True End Sub هذا الكود يرتب علي حسب colorindex لكل خلية , ارجو ان يفي بالغرض .
 
تحياتي
--+--فرز الخلايا حسب الالوان.rar

السلام عليكم
 
جرب بدل الكود بالاتي
 
Private Sub UserForm_Initialize() 'TextBox12.Visible = False TextBox2.Visible = False 'TextBox13.Visible = False Label22.Caption = "" Label2.Visible = False 'Label23.Visible = False 'Label34.Visible = False 'Label35.Visible = False 'TextBox15.Visible = False End Sub  
لاحظ ان  هناك textboxs و lables غير موجودة في الفورم و مكتوب لها اكواد (هنا المشكلة)
 
تحياتي

السلام عليكم
 
جرب هذه , لكن لاحظ ان اخر رقمين غير صحيحين .
 
 
تحياتي
+متوسط الدرجات.rar

السلام عليكم
 
جرب هذا 
 
Sub dahmour() l = Range("b" & Rows.Count).End(xlUp).Row For x = 3 To l t = 0 col = 34 For Each c In Range("c" & x & ":ag" & x) If t = 0 Then If c = "A" Then Cells(x, col) = DateSerial(Year([a2]), Month([a2]), Cells(2, c.Column).Value) t = t + 1 col = col + 1 End If Else If c = "A" Then t = t + 1 Else Cells(x, col) = DateSerial(Year([a2]), Month([a2]), Cells(2, c.Column - 1).Value) t = 0 col = col + 1 End If End If Next Next End Sub  
 
تحياتي 
CODE+.rar

السلام عليكم
 
جرب المرفق
 
-لاحظ ان المدي لل pivote و المعادلات حتي الصف 72 فقط و ليس كل البيانات .
 
-في حالة زيادة ال KP NO عن 17 سوف تحتاج لزيادتهم في التقرير يدوي و كذلك بالنسبة لل WELD ID , بينما الpivote كان يقوم بهذا اتوماتيكا .
 
تحياتي
Draft+ AHMED rev 01+.rar

السلام عليكم
 
 
جرب هذا 
 
Sub OFFICNA1() Dim LR As Long, LR2 As Long, ws As Worksheet, ws2 As Worksheet Set ws = Sheets("1") Set ws2 = Sheets("1") LR = ws.Range("a" & Rows.Count).End(xlUp).Row LR2 = ws2.Range("co" & Rows.Count).End(xlUp).Row If ws.Range("a9").Value = "" Then MsgBox ("áÇ ÊæÌÏ ÈíÇäÇÊ áÊÑÍíáåÇ") Exit Sub End If Dim c c = MsgBox("ÃäÊ ÈÕÏÏ ÊÑÍíá ÌãíÚ ÇáÓÌáÇÊ Çáì ÇáÃÑÔíÝ Ýåá ÊæÇÝÞ¿", 36, "ÊÍÐíÑ") If c = 6 Then ws.Range("a9:l" & LR).Copy ws2.Range("co" & LR2 + 1) ws.Range("a9:l" & LR).ClearContents ws.Select MsgBox "Êã ÇáÊÑÍíá ÈäÌÇÍ!", vbInformation + vbMsgBoxRight, "Êã ÇáÊÑÍíá" End If End Sub  
الفكرة في اضافة  Exit Sub
 
تحياتي

السلام عليكم
 
جرب هذا التعديل علي اول ثلاث خلاية .
 
يعتمد علي vlookup مع معامل التقريب  true  .
 
يعطيك مرونة اكبر و اخف و يعمل مع 2003  .
 
تحياتي
المعين الرشيد+.rar

جرب هذا 
AB++.rar

السلام عليكم
 
ان كنت تقصد  *1 , اعتقد انها تستخدم لتحويل النص الي رقم لكن لا اظن ان لها فائدة هنا لكني احببت عدم التعديل علي الكود فكاتبه ادرى به , و الله اعلم
 
عامتا هذا السطر يعطي المتغير x قيمة التكست بوكس المسمى textbox02  ليقوم باقي الكود بالبحث عنه و تعديل باقي السطر بدلالته .
 
المشكلة انها كانت مكتوبة  textbox1 وهو التكست بوكس الخاص بالبحث اما textbox02  فيحتوي علي القيمة للسطر المختار .
 
تحياتي

السلام عليكم
 
جرب هذا 
 
Sub HIMA() Application.ScreenUpdating = False Dim ws10 As Worksheet Set ws10 = Sheets("ÇáÈíÇäÇÊ") LR = ws10.Cells(Rows.Count, 3).End(xlUp).Row ws10.Range("X8:Z10000").ClearContents For i = 8 To LR ws10.Cells(i, 12) = ws10.Cells(i, 10) & ws10.Cells(i, 9) & ws10.Cells(i, 8) & ws10.Cells(i, 7) & ws10.Cells(i, 6) & ws10.Cells(i, 5) & ws10.Cells(i, 4) & ws10.Cells(i, 3) ws10.Cells(i, 12).NumberFormat = "@" Next i Application.ScreenUpdating = True End Sub  
او بامكانك تغير تنسيق الخلايا المراد الترحيل اليها  الي text .
 
تحياتي

السلام عليكم
 
استاذ صباح 
 
جرب المرفق
 
تحياتي
+اجازات_2.rar