حسونة حسين

وعليكم السلام ورحمه الله وبركاته تفضل اخى 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

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

ممكن ترفعه على اي موقع رفع وليكن ميديا فاير https://www.mediafire.com/

وعليكم السلام ورحمه الله وبركاته لا يمكن العمل على الصور اخى ارفق الملف الذي به المشكة

بمجرد ما تكتب رقم 4 يتم الترحيل الى شيت الارصدة عند رقم 4 في خليه b7 (دي تمام الكود فعلا يقوم بهذا ) متي تريد ان يرحل الكود الى الملف الجديد المسمى (الارصدة.xlsx) ؟ واين يرحل الكود في الملف الجديد المسمى (الارصدة.xlsx) ؟ اين يوجد التاريخ ؟ (ثم لو ضغطت على رقم 4 سوف يرحل الى ملف الارصده) ولكن لو ضغطت مره اخري على رقم 5 ما المفروض ان يفعله الكود ؟ لانه لا يوجد شرح كافي لفهم المطلوب اخى

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

ارفق صورة لمحرر الاكواد تظهر فيها اسماء الموديلات وارفق ملف به المشكله

وعليكم السلام ورحمه الله وبركاته بعد اذن اخى على عدل Dim Start_date As date, Last_date As date الى Dim Start_date As Double, Last_date As Double ووافنا بالنتيجه

الشكر لله اخي

السلام عليكم ورحمة الله وبركاته وبها نبدأ اخى ارفق الملف الذي به المشكله

المعادله اخى موجوده في الملف المرفق في المشاركه السابقه لي

وعليكم السلام ورحمة الله وبركاته تفضل لعله لطلبك الراتب الاساسى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

هذا موضوع اخر اخي الغالي قم بفتح موضوع بالطلب الجديد

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

وعليكم السلام ورحمه الله وبركاته ما الذي لا يعمل اخي ما تم تعديله هو TextBox4 فقط مفروض تعدل باقي التيكست بنفس الطريقه

وعليكم السلام ورحمه الله وبركاته عدل If .TextBox4.Value <> "" And X <> 0 Then الى If .TextBox4.Value <> "" And X <> 0 And IsNumeric(.TextBox30.Value) Then

وجزاكم مثله اخى

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

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

وجزاكم مثله اخى ابو عبدالرحمن @علي بطيخ سالم على دعاؤكم الطيب

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

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