عبدالله باقشير

السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا تقبلوا تحياتي وشكري

جزاكم الله خيرا

السلام عليكم جرب الكود التالي Sub kh_trheel() Dim Sht1 As Worksheet, Sht2 As Worksheet, Shp1 As Worksheet, Shp2 As Worksheet Dim Lr As Long, R As Long Dim t1 As String, t2 As String Set Sht1 = Sheets("البيانات الرئيسية") Set Sht2 = Sheets("البيانات الفرعية") Set Shp1 = Sheets("مشمول") Set Shp2 = Sheets("غير مشمول") With Shp1.Range("A2:E2") Range(.Cells, .Cells.End(xlDown)).ClearContents End With With Shp2.Range("A2:E2") Range(.Cells, .Cells.End(xlDown)).ClearContents End With Lr = Sht1.Range("A" & Rows.Count).End(xlUp).Row For R = 2 To Lr t1 = CStr(Sht1.Cells(R, "B")) & CStr(Sht1.Cells(R, "C")) & CStr(Sht1.Cells(R, "D")) & CStr(Sht1.Cells(R, "E")) t2 = CStr(Sht2.Cells(R, "B")) & CStr(Sht2.Cells(R, "C")) & CStr(Sht2.Cells(R, "D")) & CStr(Sht2.Cells(R, "E")) If t1 = t2 Then Shp1.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value = _ Sht1.Cells(R, "A").Resize(1, 5).Value Else Shp2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value = _ Sht2.Cells(R, "A").Resize(1, 5).Value End If Next Set Sht1 = Nothing: Set Sht2 = Nothing: Set Shp1 = Nothing: Set Shp2 = Nothing End Sub المرفق 2003 ترحيل بيانات.rar تحياتي

التهنئة بترقية الاخ حسام عيسى الى عضو مميز

السلام عليكم يكفي ان تضع هذا الكود في الفورم Private Sub UserForm_Activate() Dim i As Integer, j As Integer For i = 1 To 100 For j = 1 To 1000 DoEvents Next j Me.Text.Caption = i & "% Completed" Me.Bar.Width = i * 2 Next i End Sub تحياتي

السلام عليكم جرب هذا Private Sub TextBox1_Change() On Error GoTo 1 Me.TextBox1.BackColor = Val(Me.TextBox1) 1 End Sub تحياتي

التهنئة بترقية الاخ ibn_egypt الى عضو مميز

السلام عليكم جرب هذه المعادلة لحساب اليوم =MOD(DAYS360(E8+IF(DAY(E8)=31;1;0);D8);30) اما الشهر والسنة تبقى المعادلات مثل المرفق في المشاركة الاولى تحياتي

السلام عليكم ورحمة الله وبركاته اسمحلي اكلمك باسلوبك "التهينا شوية بامور اخرى جينا ولقيناك عامل الهوايل ومكسر الدنيا" يا اخي الحبيب حقيقة لك اسلوب تعليمي يدخّل المعلومة بالراس بالغصب جزاك الله خيراً وبارك فيك تقبلوا تحياتي وشكري

جزاكم الله خيرا

جزاكم الله خيرا

السلام عليكم ورحمة الله وبركاته الاخ الحبيب ياسر خليل .....حفظه الله سيتم تطوير الملف حسب طلباتك في هذا الموضوع الموجود في الرابط ادناه اما بخصوص التعديل في الملف القديم لا انصح به الاخ الحبيب محمد نصري.....حفظه الله تم اضافة مقترحك في رابط الموضوع ادناه الاخ الحبيب محمود الشريف.....حفظه الله شاهد الرابط ادناه http://www.officena.net/ib/index.php?showtopic=56808 السلام عليكم

السلام عليكم ورحمة الله وبركاته نموذج سريع للبحث في القرآن الكريم يمكنك البحث فيه بالتشكيل او بدونه طلب من الاخ الحبيب ياسر خليل ملحوظة : ارجوا استخدام المرفق فقط لغرض البحث واستخراج المعلومة المرفق 2003 نموذج بحث سريع في القرآن الكريم.rar

السلام عليكم جزاكم الله خيرا نسخت الجدول من هذا الملف الى ملف آخر وعملت فورم آخر للبحث يحقق ما طلبت ( على السريع) اي اضافات اخرى اشعرنا بها بحث في المصحف مع وجود التشكيل.rar

السلام عليكم اخي الحبيب ياسر ..اكرمه الله اتمنى ان تبقى دائما معنا و لاتحرمنا هذا النشاط تقبلوا تحياتي وشكري

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

السلام عليكم الكود موجود في موديل الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim iRow As Double If Intersect(Target, Range("A2:C100000")) Is Nothing Then Exit Sub iRow = Target.Row Cells(iRow, "D").Value = Val(Cells(iRow, "B")) * Val(Cells(iRow, "C")) Cells(iRow, "E").Value = Val(Cells(iRow, "D")) * 0.0012 Cells(iRow, "F").Value = IIf(CStr(Cells(iRow, "A")) = "شراء", Val(Cells(iRow, "D")) + Val(Cells(iRow, "E")), 0) Cells(iRow, "G").Value = IIf(CStr(Cells(iRow, "A")) = "بيع", Val(Cells(iRow, "D")) - Val(Cells(iRow, "E")), 0) Cells(iRow, "H").Value = Val(Cells(iRow - 1, "H")) + Val(Cells(iRow, "G")) - Val(Cells(iRow, "F")) End Sub المرفق 2010 Offcina +بالكود.rar

اذا كانت بنفس المكان وبنفس الحجم في اي ورقة او اي ملف ممكن تنفيذ هذا الكود انطلاقا من مكان وجود الجدول

السلام عليكم جرب الكود التالي: Sub kh_Sort() Dim N Dim Lr As Long, r As Long, Lrr As Long Dim c As Integer ''''''''''''' Application.ScreenUpdating = False ' اختيار العمود الاكثر طولا For c = 1 To 6 Lrr = Cells(Rows.Count, c).End(xlUp).Row If Lrr > Lr Then Lr = Lrr Next ''''''''''''' ' For r = 2 To Lr If Len(Trim(Cells(r, "A"))) Then N = Cells(r, "A").Value Else With Cells(r, "A") .Value = N .Interior.ColorIndex = 6 End With End If Next '''''''''''''''''' ' الفرز للعمود الاول With Range("A2:F" & Lr) .Sort .Columns(1), xlAscending End With '''''''''''''''''' For r = 2 To Lr With Cells(r, "A") If .Interior.ColorIndex = 6 Then .ClearContents .Interior.ColorIndex = -4142 End If End With Next Application.ScreenUpdating = True End Sub شاهدالمرفق 2010 Test100.rar

التهنئة بترقية الاخ خزاني الى عضو مميز

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم الشكر واصل للاخ عمرو رحيل ....اكرمه الله ائراءا للموضوع نفس الفكرة بدون استخدام العمود سي مباشرة بمعادلة وحدة =SUMPRODUCT(N(NOT(B2:B103>B3:B104))) تحياتي

السلام عليكم http://www.officena.net/ib/index.php?showtopic=36524 تحياتي

السلام عليكم الكود خطأ استبدل بهذا Private Sub UserForm_Initialize() Dim i As Integer For i = 6 To Cells(Rows.Count, "A").End(xlUp).Row If CStr(Cells(i, "B")) = "نعم" Then Me.ComboBox1.AddItem Cells(i, "A").Value Next End Sub تحياتي