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

غير الصف الذي في الكود الملون بالاحمر الى اي صف تريده LastColumn = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column + 1 او ارفق ملف لنفهم طلبك على الواقع

السلام عليكم هذا للعمود الاخير في الصف الاول LastColumn = Sheet2.Cells(1, Columns.Count).End(xlToLeft).Column + 1 تحياتي

السلام عليكم جزاك الله خيرا عدل في هذا الكود كالتالي : Private Sub kh_Format(iName As String, MyCel As Range) With Me.Controls(iName) .BackColor = MyCel.Interior.Color .Caption = MyCel.Text .TextAlign = 2 With .Font .Name = MyCel.Font.Name .Bold = True .Size = MyCel.Font.Size End With End With End Sub حيث تم تعديل هذا السطر فقط .Caption = MyCel.Text تحياتي

السلام عليكم شاهد المرفق 2010 احصاء اسبوعي وشهري.rar

اخي الفاضل abdoulah

السلام عليكم جرب هذا فقد جربته على اكثر من 120000 صف Sub kh_Start() Dim Obj As Object Dim tx As String Dim Rng1 As Range, Rng2 As Range Dim Cel As Range, CelDelete As Range, CelValue As Range On Error GoTo 1 ''''''''''''''''''''''''''''' With Sheets("1") Set Rng1 = .Range("B3", .Range("B" & Rows.Count).End(xlUp)) End With ''''''''''''''''''''''''''''' With Sheets("2") Set Rng2 = .Range("B3", .Range("B" & Rows.Count).End(xlUp)) End With ''''''''''''''''''''''''''''' Set Obj = CreateObject("Scripting.Dictionary") ''''''''''''''''''''''''''''' For Each Cel In Rng2 tx = Trim(Cel) If Not Obj.Exists(tx) Then Obj.Add tx, 1 Next ''''''''''''''''''''''''''''' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ''''''''''''''''''''''''''''' For Each Cel In Rng1 If Obj.Exists(CStr(Cel)) Then If CelDelete Is Nothing Then Set CelDelete = Cel Else Set CelDelete = Union(CelDelete, Cel) Else If CelValue Is Nothing Then Set CelValue = Cel Else Set CelValue = Union(CelValue, Cel) End If Next ''''''''''''''''''''''''''''' If Not CelDelete Is Nothing Then CelDelete.EntireRow.Delete If Not CelValue Is Nothing Then CelValue.Copy Sheets("2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues Application.CutCopyMode = False End If ''''''''''''''''''''''''''''' 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ''''''''''''''''''''''''''''' Set Rng1 = Nothing: Set Rng2 = Nothing: Set CelDelete = Nothing: Set CelValue = Nothing: Set Obj = Nothing If Err Then MsgBox "Err.Number : " & Err.Number Else MsgBox "الحمد لله تمت التصفية بنجاح" End Sub جرب واشعرنا بالنتيجة تحياتي

======================== الاخ الحبيب/ ضاحي الغريب ======================== و

======================== الاخ الحبيب/ ضاحي الغريب ======================== و

السلام عليكم شاهد الرابط التالي http://www.officena.net/ib/index.php?showtopic=52241

السلام عليكم بواسطة قاعدة التحقق من الصحة المرفق 2010 تقييد الترصيد.rar

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

العفو اخي.........انا تشرفت بالرد عليكم اعلى الله مقامكم وجزاكم خيرا تقبلوا تحياتي وشكري

السلام عليكم جرب المعادلة التالية =MID(A1;7;2)&"/"&MID(A1;5;2)&"/"&MID(A1;1;4) فرضنا ان الرقم في الخلية A1

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

السلام عليكم تم بالمعادلات شاهدالمرفق 2010 احضار البيانات.rar

هل تستخدم محاذاه من اليمين الى اليسار

السلام عليكم جرب هذا ايضا اظنه اسرع من السابق Sub kh_Start() Dim Rng1 As Range, Rng2 As Range Dim Cel As Range, CelDelete As Range With Sheets("1") Set Rng1 = .Range("B3", .Range("B" & Rows.Count).End(xlUp)) End With With Sheets("2") Set Rng2 = .Range("B3", .Range("B" & Rows.Count).End(xlUp)) End With For Each Cel In Rng1 If WorksheetFunction.CountIf(Rng2, Cel) Then If CelDelete Is Nothing Then Set CelDelete = Cel Else Set CelDelete = Union(CelDelete, Cel) Else Sheets("2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cel.Value End If Next If Not CelDelete Is Nothing Then CelDelete.EntireRow.Delete Set Rng1 = Nothing Set Rng2 = Nothing Set CelDelete = Nothing End Sub المرفق 2010 فزر المكرر.rar

و

السلام عليكم جرب الكود التالي Sub kh_Start() Dim Rng1 As Range, Rng2 As Range Dim Cel As Range, CelDelete As Range With Sheets("1") Set Rng1 = .Range("B3", .Range("B" & Rows.Count).End(xlUp)) End With With Sheets("2") Set Rng2 = .Range("B4", .Range("B" & Rows.Count).End(xlUp)) End With For Each Cel In Rng1 If WorksheetFunction.CountIf(Rng2, Cel) Then If CelDelete Is Nothing Then Set CelDelete = Cel Else Set CelDelete = Union(CelDelete, Cel) Else With Sheets("2") If Len(.Range("C4")) Then .Range("C4").Insert Shift:=xlDown .Range("C4").Value = Cel.Value End With End If Next If Not CelDelete Is Nothing Then CelDelete.EntireRow.Delete Set Rng1 = Nothing Set Rng2 = Nothing Set CelDelete = Nothing End Sub المرفق 2010 فزر المكرر.rar

السلام عليكم هذا بالتصفية المتقدمة المرفق 2010 حركة المخزن.rar

في هذه الحالة اترك اكواد الفورم مثل ما هي بدون تغيير مثل ماهي في المرفق في المشاركة 1 والتغير الان سيتم في كود اظهار الفورم فقط سيتم فيه تحديد الخلية التي نريدها ونمنع تنشيط اي حلية اثناء فتح الفورم مثلا كود الزر الاول Sub KH_SHOW() Range("D13").Activate With UserForm1 .kh_SetRng Sheets("t1").[B3:B200] .Show 1 End With End Sub في هذا الكود لا يمكنك التغيير الا في الخلية D13 ولا يمكنك تحديد اي خلية اخرى والفورم مفتوح وهكذا مع الزر الثاني مع تغيير خلية التعديل تحياتي

من الحلول استخدام دالة التقريب ROUND مع دالة الجمع ضع هذه الدالة في الخلية BC13 وانسخها على باقي الصفوف او اسحبها =IF(SUM(BB13;AY13;AV13;AR13;AO13;AK13;AG13;AC13;Y13;U13;Q13)=0;"";ROUND(SUM(BB13;AY13;AV13;AR13;AO13;AK13;AG13;AC13;Y13;U13;Q13);1)) جرب واشعرنا بالنتيحة

السلام عليكم جربت ذلك وانظر الى النتيجة

وعليكم السلام لم استطع التركيز على بياناتك جرب تضع رقم متساوي بطريقة يدويه في المجموع لهذين الطالبين واشعرنا بالنتيجة لانني شاكك في الفواصل العشرية ليست متساوية ... والله اعلم

في هذا الكود تحدد الخلية التي تريدها بدلا من ActiveCell Private Sub ListSearch_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Cancel = True ActiveCell.Value = Me.ListSearch.Value End Sub مثلا [A4] = Me.ListSearch.Value تحياتي