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

السلام عليكم
الشكر واصل لاخي شوقي ...حفظه الله
اثراءا للموضوع
المرفق 2003
 
الحذف.rar

السلام عليكم
 
استبدل شرط البحث بهذا
If LCase(TextBox1.Value) = LCase(cl) Then تحياتي

السلام عليكم
 
اضف زر جديد
وضع هذا الكود في الفورم
Private Sub CommandButton1_Click() Dim Lr As Long With Sheets("ارشيف")     Lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1     .Cells(Lr, "A").Value = Lr - 7     .Cells(Lr, "B").Value = Me.Controls("Textdt1")     .Cells(Lr, "C").Value = Me.Controls("Textdt3")     .Cells(Lr, "D").Value = Me.Controls("Textdt4") End With End Sub تحياتي

جزاكم الله خيرا
Private Sub CommandButton1_Click() With UserForm1     .MultiPage1.Value = 2     .Show End With End Sub page1 تاخذ القيمة 0
page2 تاخذ القيمة 1
page3 تاخذ القيمة 2
page4 تاخذ القيمة 3
 
وهكذا
تحياتي

نعم ممكن مع تعديل بسيط
Private Sub CommandButton1_Click() Dim Cntl As Control Dim Txt As String For Each Cntl In Me.Controls     If TypeOf Cntl Is MSForms.CheckBox Then         If Cntl.Value = True Then             Txt = Txt & IIf(Len(Txt), " - ", "") & Cntl.Caption         End If     End If Next Range("B2").Value = Txt End Sub تحياتي

السلام عليكم
 
ضع هذا الكود في موديل الورقة Feuil1
Private Sub CommandButton1_Click()     Range("F11:F60").Replace ",", "." End Sub تحياتي

السلام عليكم
 
ضع المعادلة هذه في الخلية G3
=INDEX($B$3:$B$12;MOD(ROW()-3;10)+1) واسحبها الى اسفل
 
رقم 3 في المعادلة هو  رقم صف اول خلية تضع فيها المعادلة وهي الخلية G3
 
تحياتي

السلام عليكم
 
جرب هذه
=SUMPRODUCT(N((($C$5:$C$139>=$C$4)*(($B$5:$B$139<$B$4)+($B$5:$B$139="غ")))>0)) تحياتي

السلام عليكم
على افتراض ان النطاق المطلوب  B4:B100
 
جرب الكود التالي:
Sub kh_Replace() Dim ch With Range("B4:B100")     For Each ch In Array("إ", "أ", "آ")         .Replace CStr(ch), "ا"     Next     .Replace "ة", "ه"     .Replace "ى", "ي" End With End Sub المرفق 2003
 
حذف الهمزة والتاء المربوطه.rar

جرب المعادلة التالية بافتراض ان الخلية C41 فيها عدد الساعات والخلية D41 فيها عدد الدقائق
=CONCATENATE(INT((C41+INT(D41/60))/7);" ايام";" و ";MOD(C41+INT(D41/60);7);" ساعات") تحياتي

السلام عليكم
 
الاخ الفاضل سمير جيد...........حفظكم الله
فعلا العنوان مخالف لقواعد المشاركة مثل ما اخبرك اخي الفاضل محمد أبو البراء
وتم تعديلة لانها المشاركة الاولى لك فيجب الانتباه مستقبلا لكتابة عناوين تدل على الطلب ويساعد في البحث للآخرين
 
اما بخصوص مشكلتك اتبع الخطوات التالية وان شاء الله تحل المشكلة
 
اكسل 2003
ادوات
خيارات
عرض
شيك على قيم الصفر
 
اكسل 2007 وما فوق
 ملف
خيارات
خيارات متقدمة
 
خيارات عرض ورقة العمل هذه
شيك على اظهار صفر في الخلايا التي تحتوي على قيم صفرية
 
تحياتي

السلامعليكم
 
جزاكم الله خيرا
 
بالنسبة لطلبك جرب الكود التالي وبامكانك تغير اماكن الاعمدة من الكود
Const wName As String = "Book1" Const ContColumn As Integer = 5 Const Txt As String = "الأول الابتدائي-الثاني الابتدائي-الثالث الابتدائي-الرابع الابتدائي-الخامس الابتدائي-السادس الابتدائي" Sub kh_Trheel() Dim xl As New Excel.Application Dim wo As Workbook Dim sh As Worksheet Dim Ary() Dim Lr As Long, r As Long, i As Long On Error Resume Next Range("A1").Resize(Cells(Rows.Count, "A").End(xlUp).Row, ContColumn).ClearContents Set wo = xl.Workbooks.Open(ThisWorkbook.Path & "\" & wName & ".xls") For Each sh In wo.Worksheets     With sh         Lr = .Cells(Rows.Count, "Q").End(xlUp).Row         For r = 23 To Lr             i = i + 1             ReDim Preserve Ary(1 To ContColumn, 1 To i)             Ary(1, i) = i             Ary(2, i) = .Cells(r, "Q").Value             Ary(3, i) = .Range("C6").Value             Ary(4, i) = .Range("C14").Value             Ary(5, i) = WorksheetFunction.Match(CStr(.Range("C6")), Split(Txt, "-"), 0)         Next     End With Next If i Then     Range("A1").Resize(i, ContColumn).Value = WorksheetFunction.Transpose(Ary) End If 1: If Not wo Is Nothing Then wo.Close False Set wo = Nothing Erase Ary On Error GoTo 0 End Sub تحياتي

السلام عليكم
 
بعد اذن اختي الفاضلة أم عبدالله
 
شاهد المرفق 2010
جمع خلايا أكسيل منفصلة.rar

السلام عليكم
الشكر واصل لاختي الفاضلة أم عبدالله
تم العمل بالمعادلات
شاهد المرفق 2010
كسف حساب 2014.rar

السلام عليكم
 
حدد النطاق الذي تريد مسحة ثم اضغط الزر
يعني لازم تستخدم الزر للمسح حتى يعمل الكود

Sub kh_CLEAR() Dim cel As Range For Each cel In Selection     If Not Intersect(cel, Range("C4:P95")) Is Nothing Then         With cel             ورقة2.Range(.Address).Value = .Value             .Interior.ColorIndex = 16             .ClearContents         End With     End If Next End Sub المرفق 2003
association.rar

السلام عليكم
 
شاهد المرفق 2003
فئات المبلغ.rar

السلام عليكم
الخلية M1 والخلية N1 وهي من خلايا المعيار
لازم يكون الكلمة التي فيها مختارة من رؤوس اعمدة البيانات
انت كاتب كلمة (السنة) وهي كلمة غير موجودة في رؤوس اعمدة البيانات
غيرها الى (سن المعاش) وجرب الكود
 
تحياتي

هذه الدالة تقوم بذلك
Option Explicit Function kh_vCont11(Rng As Range) As Long Dim Col As New Collection Dim Tx, iText, v ''''''''''''''''''''''''''''' On Error Resume Next For Each v In Rng.Cells     For Each Tx In Split(CStr(v), ",")         Col.Add 1, Trim(Tx)     Next Next kh_vCont11 = Col.Count Set Col = Nothing On Error GoTo 0 End Function شاهد المرفق 2003
example++.rar

السلام عليكم

الشكرواصل للاخ حسين ........حفظه الله
ائراءا للموضوع
هذه دالة بالكود
Option Explicit Function kh_EDateHijri(sDate, Months As Integer) Dim MyDate As Date Calendar = vbCalHijri '---------------------- MyDate = DateSerial(Year(sDate), Month(sDate) + Months + 1, 0) If Day(MyDate) = 1 Then MyDate = MyDate - 1 '---------------------- kh_EDateHijri = Format(MyDate, "dd/mm/yyyy") '---------------------- Calendar = vbCalGreg End Function المرفق 2003
الفترة لآخر الشهر بعدد اشهر معين (هجري(.rar

السلام عليكم
 
جرب الكود التالي

Sub Macro1() Dim i As Integer Dim ib As Boolean With Worksheets     For i = 1 To .Count         ib = WorksheetFunction.CountIf(Range("A3:A100"), i)         If ib Then .Item(i).Visible = 0 Else .Item(i).Visible = -1     Next End With End Sub المرفق 2010
 
أوراق.rar

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

السلام عليكم

تم استخدام الاكواد التالية:
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

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

السلام عليكم
 
 
شاهد المرفق 2010
Orginal.rar

السلام عليكم
الشكر واصل للجمع المبارك
اسمحولي مشاركتكم هذا الحل
المرفق 2003
Add.rar