حسونة حسين

السلام عليكم ورحمة الله وبركاته وبها نبدأ 
تأكد من انه لا يوجد مشكله في اعدادات اللغه العربيه في الجهاز
لان الكود (الرئيسيه) ليس به مشكله 

وعليكم السلام ورحمه الله وبركاته
الكود ليس به مشكله اخى
انما المشكله في ادخال البيانات
تأكد من ان البيانات ليس بها خطأ
#DIV/0!
مثل هذه الصورة

وعليكم السلام ورحمه الله وبركاته
تفضل اخى
Private Sub CommandButton1_Click() Dim Ws As Worksheet, Arr, dic As Object, Levels, X Dim i As Long, R As Long, j As Long, P As Long Set Ws = ThisWorkbook.Worksheets("main") Arr = Ws.Range("A2:B" & Ws.Cells(Rows.Count, 1).End(xlUp).Row).Value Set dic = CreateObject("Scripting.Dictionary") R = 1 Levels = Array(TextBox1, TextBox2, TextBox3) Me.ListBox1.Clear ReDim B(1 To UBound(Arr, 1)) For i = LBound(Arr, 1) To UBound(Arr, 1) If Not dic.Exists(Arr(i, 1)) Then dic.Add Arr(i, 1), R B(R) = Arr(i, 1) & "-" & Split(Arr(i, 2))(0) R = R + 1 Else B(dic(Arr(i, 1))) = B(dic(Arr(i, 1))) & "-" & Split(Arr(i, 2))(0) End If Next i ReDim Tmp(1 To R - 1) For i = LBound(B, 1) To R - 1 If UBound(Split(B(i), "-")) = UBound(Levels) + 1 Then For j = 1 To UBound(Levels) + 1 X = Application.Match(Split(B(i), "-")(j), Levels, 0) If IsError(X) Then GoTo 1 Next j P = P + 1 Tmp(P) = Split(B(i), "-")(0) End If 1 Next i If P > 0 Then Me.ListBox1.List = Application.Index(Tmp, Evaluate("row(1:" & P & ")")) End Sub  
 
test.xlsm

وعليكم السلام ورحمة الله وبركاته 
ضع هذه المعادله في الخليه C6
ثم اسحب يسارا ونزولا لاسفل
 
مثال.xlsx

وعليكم السلام ورحمة الله وبركاته 
تفضل لعله لطلبك
 
الراتب الاساسى212 مارس.xlsx

قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة
و بصفة خاصة نؤكدعلى ما يلي
1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة
2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد.
3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال.
4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا.....
5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم.
ومخالفة ذلك تعرض الموضوع للحذف  
هذا الموضوع مخالف لقوانين المنتدي
××××××××
موضوع مكرر.
××××××××
يغلق
××××××××
الإدارة

وعليكم السلام ورحمه الله وبركاته
تفضل اخى
Option Explicit Sub Search_Delete() Dim Arr As Variant, SH As Worksheet, dic As Object Dim I As Long, Unique_No As String, R As Range, P As Long Application.ScreenUpdating = False: Application.EnableEvents = False Set SH = ThisWorkbook.Worksheets("ورقة1") Arr = SH.Range("B2:F" & SH.Cells(Rows.Count, 2).End(xlUp).Row).Value Set dic = CreateObject("Scripting.Dictionary") dic.CompareMode = 1 For I = LBound(Arr) To UBound(Arr) Unique_No = Arr(I, 1) & Arr(I, 4) & Arr(I, 5) If Not dic.Exists(Unique_No) Then dic.Add Unique_No, P P = P + 1 Else If R Is Nothing Then Set R = SH.Cells(I + 1, 1) Else Set R = Union(R, SH.Cells(I + 1, 1)) End If End If Next I If Not R Is Nothing Then R.EntireRow.Delete Application.EnableEvents = True: Application.ScreenUpdating = True End Sub  
 

وعليكم السلام ورحمه الله وبركاته
جرب هذا التعديل
كود عمل فورمات للخلية عند التعديل.xlsm

وعليكم السلام ورحمه الله وبركاته
مبارك علينا وعليكم
تفضل
=VLOOKUP(A4,البيانات!$A$2:$E$8,MATCH($D$3,البيانات!$A$1:$E$1,0),0)  
معادلة على اساس رأس الجدول.xlsm

وعليكم السلام ورحمه الله وبركاته
تفضل اخي لعله طلبك ان شاء الله
 
التوزيعات بدون حماية.xlsm

وعليكم السلام ورحمة الله وبركاته 
تفضل اخى لعلها طلبك 
=ROUNDDOWN(L10/N10,0) & " " & L10-SUM(ROUNDDOWN(L10/N10,0)*N10) & "/" & N10  
 

قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة
و بصفة خاصة نؤكدعلى ما يلي
1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة
2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد.
3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال.
4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا.....
5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم.
ومخالفة ذلك تعرض الموضوع للحذف  
هذا الموضوع مخالف لقوانين المنتدي
××××××××
انتهاك حقوق الملكيه
××××××××
يغلق
××××××××

وعليكم السلام ورحمه الله وبركاته
تفضل اخي هانى
 
 
Unique.xlsb

السلام عليكم ورحمه الله وبركاته وبها نبدأ
الملف ليس به اي بيانات وهو ايضا ليس بملف اوفيس
حاول تعمل ريكوفر باي برنامج ريكفر لعل وعسي تجد نسخه سليمة
هذا رابط برنامج 
Active Partition Recovery Professional 15.0.0 Portable
لعله يفيدك ان شاء الله

جزاكم الله خيرا اخى ابو يوسف @محمد حسن المحمد
جزاكم الله خيرا اخي @محمد يوسف ابو يوسف
جزاكم الله خيرا علي التنبيه
وهذا نص تقرير اخى ابو يوسف محمد حسن المحمد جزاه الله خيرا
السلام عليكم ورحمة الله وبركاته
إخوتي أساتذتي الكرام: تحية طيبة وبعد أرى أن هذا الموضوع وإن كان في ظاهره يخص سؤال أو أكثر في الإكسل،إلا أنه في حقيقة الأمر
يفتح باباً واسعاً لما لا يرضي الله وهو ما يخالف برأيي منهجنا كمسلمين
فقد ثبت عن النبي ﷺ أنه قال: من اقتبس شعبة من النجوم؛ فقد اقتبس شعبة من السحر، زاد ما زاد فتعلم التنجيم لمعرفة الحوادث، ودعوى علم الغيب هذا منكر عظيم
وإنما هي كما قال الله -جل وعلا- زينةٌ للسماء، ورجوم للشياطين، وعلامات يهتدى بها، فمن تعلمها لمعرفة الطرق، وأوقات الحراثة، وأشباه ذلك مما هو معروف؛ فهذا لا بأس به، أما أن يتعلمها لاعتقاد أنه بهذا يعلم الغيب، أو لأنها هي المحدثة للحوادث، فهذا كله خلاف منهجنا وديننا
والواجب على المؤمن أن يتقيد بالأمر الشرعي، وأن يحذر ما نهى الله عنه، والله يقول: قُل لَّا يَعْلَمُ مَن فِي السَّمَاوَاتِ وَالْأَرْضِ الْغَيْبَ إِلَّا اللَّهُ فالغيب عنده  وهو الذي يعلمه -جل وعلا- وليس عند المنجمين والسحرة والكهنة، ونحو ذلك ممن يدعون علم الغيب. جزاكم الله خيرًا. 
 

استبدل المعادله في العامود G
بهذه المعادله
=IF(H5="";E5;0)+F5+D5  

النسبه ٢٠ % من اجمالي التوريد
=IF(V1<AD1;V1*0.2;IF(V1>=AD2;V1*0.25;IF(V1>=AD3;V1*0.27)))-V2 ام من ال ٣٤٥٠٠
=IF(V1<AD1;AD1*0.2;IF(V1>=AD2;AD2*0.25;IF(V1>=AD3;AD3*0.27)))-V2  

تفضل اخي جرب هذا التعديل
الفولدر المسمي 
صور الموظفين
لابد ان يكون موجود بجوار هذا الملف 
ادخال بيانات اطفال الروضة حضانة.xlsm

وعليكم السلام ورحمه الله وبركاته
تفضل اخي ياسر @yasse.w.2010 تعديل بسيط على كودك
وتم اضافه شرط ان لم يكن يوجد صفحه بالاسم الذي تريد ان لا يعطى خطأ ويفتح الملف التالي
Sub information() Dim wb As Workbook, WS As Worksheet, lr1 As Integer, lr2 As Integer Dim fil As Variant, dat As Long Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("Temp") Application.ScreenUpdating = False ''' غلق اهتزاز الشاشه Application.DisplayAlerts = False ''' غلق اي رساله تظهر مثل الحفظ الخ lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row ''' ار صف فيه بيانات في العامود الاول sh.Range("A10:k" & lr1 + 1).ClearContents '''مسح البيانات في هذا النطاق INF = ThisWorkbook.Path '''مسار الملف fil = Dir(INF & "\*.xl??") ''' مسار الملف في اي مكان Do While fil <> "" ''' المرور على كل الملفات If fil <> "DATA.xlsm" Then ''' اسم الملف الذي لا يتم جلب البيانات منه Set wb = Workbooks.Open(INF & "\" & fil) ''' فتح الملففات من المسار lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 ''' تحديد مكان نسخ الخلايا If Not IsError(Evaluate("ISREF('[" & wb.Name & "]" & "reservation" & "'!A1)")) Then Set WS = wb.Worksheets("reservation") lr2 = WS.Cells(Rows.Count, 2).End(xlUp).Row ''' تحديد عامود اخر خليه بها بيانات ليتم نسخها WS.Range("A8:k" & lr2).Copy '''نسخ البيانات من الملف الى ملف اخر sh.Range("a" & lr1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False dep = Left(wb.Name, Application.Search(".", wb.Name) - 1) ''' تحديد اسم اسم الملف و الغاء الامتداد الخاص بالملف sh.Range("h" & lr1 & ":h" & lr1 + lr2 - 8) = dep ''' مكان اسم الملف End If wb.Close ''' غلق الملف End If fil = Dir ''' تكرار الملفات Loop Application.DisplayAlerts = True ''' فتج اهتزاز الشاشه Application.ScreenUpdating = True ''' فنح رسائل الحفظ End Sub

السلام عليكم ورحمه الله وبركاته
تفضل اخى
Private Sub CommandButton1_Click() Dim X X = Application.Match(TextBox1, Sheet1.Columns(3), 0) If IsError(X) Then MsgBox "الكود غير موجود" End If End Sub  

وعليكم السلام ورحمه الله وبركاته
استبدل الاكواد في فورم 8 بهذه الاكواد
Private Sub CommandButton1_Click() Dim LRow As Long Dim namsh As String Dim wk, wk2 As Worksheet Dim x As Integer Dim check As Boolean namsh = "temp" Set wk = ThisWorkbook.Worksheets("التكويد") For Each wk2 In ThisWorkbook.Worksheets If wk2.Name Like namsh Then check = True: Exit For Next If check = False Then With ThisWorkbook .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh End With End If Set wk2 = ThisWorkbook.Worksheets(namsh) wk2.Range("A1:E9999") = "" LRow = wk.Range("A999").End(xlUp).Row wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1") With wk2 Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row)) .Range("B" & Rowz + 2) = "الاجمالي" .Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)" .Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)" .Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)" .Columns("A:E").AutoFit With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2) .AddIndent = True .Font.FontStyle = "Times New Roman" .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Interior.Color = RGB(237, 237, 220) .Font.Bold = False .Font.Bold = True End With .PageSetup.PrintArea = "A1:E" & Rowz + 2 'LRow Application.Dialogs(xlDialogPrint).Show End With Application.DisplayAlerts = False If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub If Evaluate("=ISREF('" & namsh & "'!A1)") Then Sheets(namsh).Delete End If Application.DisplayAlerts = True wk.Activate End Sub Private Sub CommandButton2_Click() With ThisWorkbook.Worksheets("التكويد") With .Range("A1:T1") If Me.ComboBox1.Text = "" Then Exit Sub .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text & "*" End With Call CommandButton1_Click If .AutoFilterMode Then .ShowAllData End If End With End Sub Private Sub CommandButton3_Click() Unload Me End Sub Private Sub UserForm_Activate() Dim wk As Worksheet Dim v, e If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If Set wk = ThisWorkbook.Worksheets("التكويد") LRow = wk.Range("A999").End(xlUp).Row v = wk.Range("C2:C" & LRow).Value With CreateObject("scripting.dictionary") .comparemode = 1 For Each e In v If Not .exists(e) Then .Add e, Nothing Next If .Count Then Me.ComboBox1.list = Application.Transpose(.keys) End With End Sub  

وعليكم السلام ورحمه الله وبركاته
جرب هذا التعديل اخي @ehabaf2
Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim X As Range For Each X In Target ' 600 هو اخر سطر لعمل الكود 'L هو العامود column 12 If (X.Row < 600 And X.Column < 12) Then If ActiveSheet.ProtectContents = True And X.Value <> "" Then X.Offset(0, 1).Select End If Next End Sub  
عدم التعديل فى اسطر محددة.xlsb

السلام عليكم ورحمة الله وبركاته وبها نبدأ
@دم الغزال
استبدل هذا السطر
Application.SendKeys ("{ESC 2}") بهذا السطر
Application.CutCopyMode = False  
وان استمر الخطأ ارفق ملف للعمل عليه

وعليكم السلام ورحمه الله وبركاته
اخي @ابوعلي الحبيب
الكود الخاص بك في المشاركه الاولي ليس به اي مشكله  لكن تأكد ان المسار الذي تحفظ به الصورة موجود
 
وهذا كود اخر بسيط سوف يقوم بإنشاء المسار ان لم يكن موجود ويحفظ الصورة
Option Explicit Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean Sub Export_Range_As_Picture() Dim Ws As Worksheet, StrToFolder2 As String Dim oRng As Range, sPath As String, oChart As ChartObject Set Ws = ActiveSheet Application.ScreenUpdating = False StrToFolder2 = "D:\pic\" MakeSureDirectoryPathExists StrToFolder2 sPath = StrToFolder2 & Ws.Range("a1").Value & "." & "jpg" Set oRng = Ws.Range("A3:H17") oRng.CopyPicture xlScreen, xlPicture Set oChart = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1) With oChart .Activate .Chart.Paste .Chart.Export Filename:=sPath .Delete End With Application.ScreenUpdating = True End Sub  
 

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