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

السلام عليكم اشارك بهذا التقويم الذي يجمع التقويم الميلادي والهجري وقد صممته قديما للصيام واتمنى ان ينتفع فيه باعمال ممائلة المرفق 2003 تقويم الصيام.rar تقبلوا تحياتي وشكري ===================================== تم تعديل الملاحظة التي اورده الاخ منسق مع اضافة ورقة لاظهار الشهر الحالي تقويم الصيام.rar =====================================

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

السلام عليكم ليس هناك خطا في ان تكون النتيجة صفر يعني هذا التعبير صحيح Me.Controls.Item(0).Value لان الخاصية TabIndex تبدا بالقيمة صفر وليس هناك خطا في الكود من ناحية ترتيب الكنترولات KH = 0 For s = 1 To 15 ' عدد الصفوف For r = 1 To 11 ' عدد الاعمده sh.Cells(lr + s, r + 4) = Me.Controls.Item(KH + r - 1).Value Next KH = KH + 11 ولكن الخطا في ترتيب الخاصية TabIndex لكل كنترول المعني بالترحيل بحيث يتم ترتيبه ابتداءا من القيمة صفر حسب الاعمدة ثم بالتوالي حسب الصفوف وحقيقة استغرب كيف نناقش كود بدون وجود مرفق من صاحب المسالة تقبلوا تحياتي وشكري

السلام عليكم الشكر واصل لاخي ابوحنين تم فرز البيانات حسب عمود الاسم بعد مسح الخلايا التي لا توجد فيها معادلات Sub trheel() Dim cel As Range Dim Lr As Long, Lrr As Long, R As Long, i As Long, iCont As Long With Sheets("البيانات") Lr = .Cells(Rows.Count, "B").End(xlUp).Row iCont = WorksheetFunction.Max(.Range("A3").Resize(Lr)) Lrr = Cells(Rows.Count, "D").End(xlUp).Row For R = 3 To Lrr If Cells(R, "O").Value = "ناجح" Then i = i + 1 .Cells(Lr + i, "A").Value = iCont + i .Cells(Lr + i, "B").Resize(1, 13).Value = Cells(R, "B").Resize(1, 13).Value .Cells(Lr + i, "O").Value = [I1] .Cells(Lr + i, "P").Value = [M1] If cel Is Nothing Then Set cel = Cells(R, "A").Resize(1, 13) Else Set cel = Union(cel, Cells(R, "A").Resize(1, 13)) End If Next End With If i Then On Error Resume Next cel.SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 With Range("A3:M" & Lrr) .Sort .Columns(4), xlAscending End With End If Set cel = Nothing End Sub تحياتي

السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا حسب ما رايت سيتم حذف الصفوف جرب التالي Sub trheel() Dim cel As Range Dim Lr As Long, R As Long, i As Long, iCont As Long With Sheets("البيانات") Lr = .Cells(Rows.Count, "B").End(xlUp).Row iCont = WorksheetFunction.Max(.Range("A3").Resize(Lr)) For R = 3 To Cells(Rows.Count, "D").End(xlUp).Row If Cells(R, "O").Value = "ناجح" Then i = i + 1 .Cells(Lr + i, "A").Value = iCont + i .Cells(Lr + i, "B").Resize(1, 13).Value = Cells(R, "B").Resize(1, 13).Value .Cells(Lr + i, "O").Value = [I1] .Cells(Lr + i, "P").Value = [M1] If cel Is Nothing Then Set cel = Cells(R, "A") Else Set cel = Union(cel, Cells(R, "A")) End If Next End With If i Then cel.EntireRow.Delete Set cel = Nothing End Sub واشعرنا بالنتيجة تقبلوا تحياتي وشكري

السلام عليكم بالنسبة للترحيل الى ورقة البيانات Sub trheel() Dim cl As Range Dim Lr As Long, i As Long With Sheets("البيانات") Lr = .Cells(Rows.Count, "B").End(xlUp).Row For Each cl In Range("o3:o" & [o10000].End(xlUp).Row) If cl.Value = "ناجح" Then i = i + 1 .Cells(Lr + i, "B").Resize(1, 13).Value = cl.Offset(0, -13).Resize(1, 13).Value .Cells(Lr + i, "O").Value = [I1] .Cells(Lr + i, "P").Value = [M1] End If Next End With End Sub اما المسح اظن انك تقصد به حذف الصف لان المسح سيبقي الفراغات جرب الكود اولا تحياتي

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

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

السلام عليكم ضع هذا السطر بداية الكود UserForm_Initialize Me.RightToLeft = True تحياتي

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

السلام عليكم اولا تعمل كود رئيسي بهذا الشكل Private Sub kh_Start(tx1 As MSForms.TextBox, tx2 As MSForms.TextBox, tx3 As MSForms.TextBox) If tx1 = 0 Or tx1 = "" Then tx1 = 17 tx2 = 18 tx3 = 1 Else If tx1 = 17 Then tx1 = 18 tx2 = 19 tx3 = 1 Else If tx1 = 18 And tx2 = 19 Then tx1 = 17 tx2 = 19 tx3 = 2 Else If tx1 = 1817 And tx2 = 19 Then tx1 = 0 tx2 = 0 tx3 = 0 End If End If End If End If End Sub بعدين في ازرار تفعيل الكود تحدد التاكستات المعنية في kh_Start مثلا CommandButton1_Click Private Sub CommandButton1_Click() kh_Start TextBox1, TextBox2, TextBox3 End Sub مثلا CommandButton3_Click Private Sub CommandButton3_Click() kh_Start TextBox4, TextBox5, TextBox6 End Sub وهكذا مع بفية الازرار تحياتي

السلام عليكم تم استخدام الاكواد التالية: Option Explicit Private Const ContColmn As Integer = 5 '====================================================== '====================================================== Sub kh_Report() Dim obj As Object Dim xx(), x() Dim v As String Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long Dim C As Integer '''''''''''''''''''''' On Error GoTo kh_ex Set obj = CreateObject("Scripting.Dictionary") ''''''''''''''''''''' '============================================ With Range("B9:F9") .ClearContents Range(.Offset(1, 0), .Offset(1, 0).End(xlDown)).Clear End With '============================================ kh_Application False ''''''''''''''''''''' With Sheets("database") LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row For i = 5 To LastRow If kh_Test(CStr(.Cells(i, "F")), .Cells(i, "C").Value2) Then v = .Cells(i, "E").Value If obj.Exists(v) Then iii = obj(v) '''''''''''''''''' xx(3, iii) = xx(3, iii) + Val(.Cells(i, "G")) xx(4, iii) = xx(4, iii) + Val(.Cells(i, "H")) Else ii = ii + 1 ReDim Preserve xx(1 To 4, 1 To ii) obj.Add v, ii '''''''''''''''''' xx(1, ii) = ii xx(2, ii) = v xx(3, ii) = Val(.Cells(i, "G")) xx(4, ii) = Val(.Cells(i, "H")) End If End If Next End With ''''''''''''''''''''''''''''''' iCont = obj.Count If iCont Then ReDim x(1 To iCont, 1 To ContColmn) For i = 1 To iCont For C = 1 To 4 x(i, C) = xx(C, i) Next x(i, 5) = x(i, 3) - x(i, 4) Next With Range("B9").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = x Range("RngTotal").Copy .Cells(iCont + 1, 1) .Cells(iCont + 1, 3) = WorksheetFunction.Sum(.Columns(3)) .Cells(iCont + 1, 4) = WorksheetFunction.Sum(.Columns(4)) End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' '''''''''''''''''' '''''''''''''''''' Set obj = Nothing Erase xx, x '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear End If End Sub Function kh_Test(Nm As String, Dt) As Boolean Dim ib As Boolean If Nm <> [C5] Then GoTo 1 Select Case Dt Case [E5] To [E6] ib = True End Select 1: kh_Test = ib End Function Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub شاهد المرفق 2010 تقرير خبوري.rar

الذي يظهر على الليبلات هو نطاق صف رؤوس اعمدة البيانات يعني ما هومكتوب في راس العمود يظهر في الليبل من فضلك اقرأ الشرح !!!!!!!!!!!!!!!

السلام عليكم وهذه معادلة =SUBSTITUTE(TRIM(C3);" ";"-")

السلام عليكم هذه معادلة بالكود تقوم بذلك Function kh_Replace(Txt As String) Dim t As String t = WorksheetFunction.Trim(Txt) t = Replace(t, " ", "-") kh_Replace = t End Function لنفرض ان الخلية C3 فيها النص الذي تريد تحويله =kh_Replace(C3) تحياتي

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

السلام عليكم جزاكم الله خيرا هذه معادلة اخرى لاسم العميل ( ليست معادلة صفيف ) =INDIRECT("C"&LOOKUP(2;1/(SUBTOTAL(3;OFFSET(C6;ROW(C6:C150)-6;;1)));ROW(C6:C150))) ممكن تستخدمها هكذا علشان تعطيك كلمة اخرى في حالة عدم وجود فلترة =IF(SUBTOTAL(3;C6:C150)=COUNTA(C6:C150);"ALL";INDIRECT("C"&LOOKUP(2;1/(SUBTOTAL(3;OFFSET(C6;ROW(C6:C150)-6;;1)));ROW(C6:C150)))) تقبلوا تحياتي وشكري

السلام عليكم اتقصد هكذا لمرفق 2010 معادلة الرصيد.rar

ليس باستطاعتي `ذلك ......تقبل اعتذاري وتحياتي وشكري

يتم ذلك عن طريق الكود اقرأ المشاركة الاولى او الشرح الذي في الملف تحياتي

وعليكم السلام هل قرأت المشاركة الاولى ؟؟ تستطيع اضافة قائمة لعمود معين في الفورم باضافة تعليق على عنوان العمود وتكتب اسم نطاق القائمة . تحياتي

نعم ممكن لكن يحتاج الى شغل كثير تقبلوا تحياتي وشكري

تم تعديل العنوان وارجو الالتزام بقواعد المشاركة يجب اختيار عنوان مناسب لموضوعك

السلام عليكم الف مليوووووووووووووووون مبروك والى الامام دوما............. تقبلوا تحياتي