نجوم المشاركات

شوف اخي اول حقل = اول حقل =Column(0) والثاني Column(1) وهذا اي يعتبر اذكان رقم 4 فسيكون Column(3) واذا لم ينفع ارفع الملف مع شرح المطلوب

الله يعطيك العافية اخي الكريم ويزيدك من علمه ويحسن ختامنا وختامكم

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

اتفضل =Count(*) المحاضرات والقاعة.accdb

ممكن ترفع مثال لما تريد

الكمبيوتر يتكلم اللغة الانجليزية فى الاكسل فيديورقم2 الصور الفيديو

نفترض ان الحقل المراد عده هو box Box.ListCount

Me.Box.RowSource = "SELECT tb1.ت, tb1.[العنوان الوظيفي], tb1.[تاريخ التعيين], tb1.الملاحظات " & vbCrLf & _ "FROM tb1;"

ارفع الجدول مع تحديد ماتريد اخفائها

حياك الله استاذ تسلم

تم تفعيل الجدول لغاية المرتبة 1000 ترتيب الطلاب _Up_100.xlsm

تم معالجة الامر الكود Option Explicit Sub resume_facture() Dim my_arr2(1 To 2) my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ": Dim i%, k%, m%: m = 2 Dim s# Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row Dim laste_e% Dim laste_B% Detail.Range("A1:e" & lr2).ClearContents By_Date.Range("a1:b" & lr3).ClearContents Dim Fter_Rg As Range Set Fter_Rg = Achat.Range("a1:e" & lr1) Dim Col As Object Set Col = CreateObject("system.collections.arraylist") With Col For i = 2 To lr1 If Not .contains(Achat.Range("b" & i).Value) Then _ .Add Achat.Range("b" & i).Value Next End With For i = 0 To Col.Count - 1 '----------------------------- laste_e = Detail.Cells(Rows.Count, 1).End(3).Row If laste_e% <> 1 Then laste_e% = laste_e% + 2 '========================= Fter_Rg.AutoFilter 2, Col.Item(i) Fter_Rg.SpecialCells(12).Copy _ Detail.Range("a" & laste_e%) Next Fter_Rg.AutoFilter Col.Clear '========================= By_Date.Cells(1, 1).Resize(, 2) = my_arr2 For i = 2 To lr1 If Not Col.contains(Achat.Range("d" & i).Value) Then _ Col.Add Achat.Range("d" & i).Value Next '========================= For i = 0 To Col.Count - 1 By_Date.Range("b" & i + 2) = Col.Item(i) For k = 2 To Fter_Rg.Rows.Count If Achat.Range("D" & k) = Col.Item(i) Then s = s + Achat.Range("C" & k) End If Next By_Date.Range("A" & i + 2) = s s = 0 Next Creat_formula '=================== End Sub Rem+++++++++++++++++++++++++++++++++++++++++++++++++ Sub Creat_formula() With Detail Dim arr1(), arr2(), k%: k = 1 Dim t%: t = 1 Dim i% Dim Ro%: Ro = .Cells(Rows.Count, 2).End(3).Row For i = 2 To Ro + 1 If .Cells(i, 2) = "" Then .Cells(i, 1) = "Sum" End If Next .Range("F2:F" & Ro).Formula = "=IF(NOT(ISNUMBER(C2)),"""",SUM(C2,-E2))" '========================== For i = 1 To Ro + 1 If .Cells(i, 1) = "رقم بطاقة السكن" Then ReDim Preserve arr1(1 To k): arr1(k) = (.Cells(i, 1).Row) + 1 k = k + 1 End If Next For i = 1 To Ro + 1 If .Cells(i, 1) = "Sum" Then ReDim Preserve arr2(1 To t): arr2(t) = (.Cells(i, 1).Row) - 1 t = t + 1 End If Next '========================= For i = LBound(arr1) To UBound(arr1) With .Cells(arr2(i) + 1, 3) .Formula = "=SUM(C" & arr1(i) & ":C" & arr2(i) & ")" .Offset(, 2).Formula = "=SUM(E" & arr1(i) & ":E" & arr2(i) & ")" .Offset(, 3).Formula = "=SUM(F" & arr1(i) & ":F" & arr2(i) & ")" End With Next Erase arr1: Erase arr2 End With End Sub _Version _1 _salim.xlsm

وعليكم السلام , اهلا بك اخى الكريم فى المنتدى عليك بوضع هذا الكود فى حدث الصفحة التى تقوم بالكتابة عليها Private Sub Worksheet_Change(ByVal Target As Range) Cells.Select Selection.Rows.AutoFit Selection.Columns.AutoFit Range("A1").Select End Sub وذلك عن طريق كليك يمين فى الأسف على اسم الصفحة ثم View Code ستفتح لك نافذة اخرى عليك لصق هذا الكود بها بارك الله فيك وموفق ان شاء الله

جرب هذا الملف وبأذن الله سيفي بالغرض .... جدول الشراء.xlsx

تفضل جلب البيانات بثلاث شروط2.rar

نوجد دالة مغرفة للعدد حتى رقم 1000 اليك الكود لهذا الامر Option Explicit Function Order_Salim(cel) Dim degree$, i%, My_num1%, My_num2% Dim aHad$, Asharat$ If Not IsNumeric(cel) Then Order_Salim = "N/A": Exit Function If cel = 100 Then Order_Salim = "المائة": Exit Function End If If cel > 100 Then Order_Salim = "too Big Number": Exit Function End If cel = Int(Abs(cel)) Dim deg1$, deg2$, deg3$, deg4$, deg5$, deg6$, deg7$, deg8$, deg9$, deg10$ deg1 = "الأوّل": deg2 = "الثّاني": deg3 = "الثّالث": deg4 = "الرّابع" deg5 = "الخامس": deg6 = "السّادس": deg7 = "السّابع": deg8 = "الثّامن": deg9 = "التّاسع": deg10 = "العاشر" Dim deg01$, deg02$, deg03$, deg04$, deg05$, deg06$, deg07$, deg08$, deg09$ deg01 = "عشر": deg02 = "والعشرون": deg03 = "والثّلاثون": deg04 = "والأربعون": deg05 = "والخمسون" deg06 = "والستون": deg07 = "والسّبعون": deg08 = "والثّمانون": deg09 = "والتّسعون" If cel < 11 Then Select Case cel Case Is = 1: degree = deg1 Case Is = 2: degree = deg2 Case Is = 3: degree = deg3 Case Is = 4: degree = deg4 Case Is = 5: degree = deg5 Case Is = 6: degree = deg6 Case Is = 7: degree = deg7 Case Is = 8: degree = deg8 Case Is = 9: degree = deg9 Case Is = 10: degree = deg10 End Select Order_Salim = degree: Exit Function Else My_num1 = Mid(cel, 2, 1) '=========================== Select Case My_num1 '======================= Case Is = 1: aHad = "الحادي" Case Is = 2: aHad = deg2 Case Is = 3: aHad = deg3 Case Is = 4: aHad = deg4 Case Is = 5: aHad = deg5 Case Is = 6: aHad = deg6 Case Is = 7: aHad = deg7 Case Is = 8: aHad = deg8 Case Is = 9: aHad = deg9 End Select '====================== My_num2 = Mid(cel, 1, 1) Select Case My_num2 Case Is = 1: Asharat = deg01 Case Is = 2: Asharat = deg02 Case Is = 3: Asharat = deg03 Case Is = 4: Asharat = deg04 Case Is = 5: Asharat = deg05 Case Is = 6: Asharat = deg06 Case Is = 7: Asharat = deg07 Case Is = 8: Asharat = deg08 Case Is = 9: Asharat = deg09 End Select If My_num1 = 0 Then Order_Salim = Right(aHad & " " & Asharat, Len(aHad & " " & Asharat) - 2) Else Order_Salim = aHad & " " & Asharat End If End If End Function '=========================================================== Function OrdeUP100(cel) If Not IsNumeric(cel) Or Int(cel) <> cel Or Int(cel) <= 0 Then OrdeUP100 = "ERROR": Exit Function End If If cel = 1000 Then OrdeUP100 = "الألف": Exit Function If cel > 1000 Then OrdeUP100 = "Too Large Integer": Exit Function Dim x, y Dim Mi3at, Free, Martab1 If cel <= 99 Then OrdeUP100 = Order_Salim(cel): Exit Function Select Case Left(cel, 1) Case Is = 1: Mi3at = "مئة" Case Is = 2: Mi3at = "مئتين" Case Is = 3: Mi3at = "ثلاثمائة" Case Is = 4: Mi3at = "أربعمئة" Case Is = 5: Mi3at = "خمسمئة" Case Is = 6: Mi3at = "ستمئة" Case Is = 7: Mi3at = "سبعمئة" Case Is = 8: Mi3at = "ثمانمئة" Case Is = 9: Mi3at = "تسعمئة" End Select If Mid(cel, 2, 1) = 0 Then Free = Right(cel, 1) Select Case Free Case 0: Martab1 = "" Case 1: Martab1 = " وواحد" Case 2: Martab1 = "وإثنين" Case 3: Martab1 = "وثلاثة" Case 4: Martab1 = "وأربعة" Case 5: Martab1 = "وخمسة" Case 6: Martab1 = "وستة" Case 7: Martab1 = "وسبعة" Case 8: Martab1 = "وثمانية" Case 9: Martab1 = "وتسعة" End Select OrdeUP100 = Mi3at & " " & Martab1: Exit Function End If OrdeUP100 = Mi3at & " و" & Order_Salim(Mid(cel, 2, 2) * 1) End Function استعمال الدالة ( العدد ) Function OrdeUP100 الملف مرفق order_up_to_100.xlsm

جرب هذا الماكرو Option Explicit Sub resume_facture() Dim my_arr2(1 To 2) my_arr2(1) = "مجموع مبلغ الشراء حسب التاريخ": my_arr2(2) = "التاريخ": Dim i%, k%, m%: m = 2 Dim s# Dim lr1%: lr1 = Achat.Cells(Rows.Count, 1).End(3).Row Dim lr2%: lr2 = Detail.Cells(Rows.Count, 1).End(3).Row Dim lr3%: lr3 = By_Date.Cells(Rows.Count, 1).End(3).Row Dim laste_D% Dim laste_B% Detail.Range("A1:D" & lr2).ClearContents By_Date.Range("a1:b" & lr3).ClearContents Dim Fter_Rg As Range Set Fter_Rg = Achat.Range("a1:d" & lr1) Dim Col As Object Set Col = CreateObject("system.collections.arraylist") With Col For i = 2 To lr1 If Not .contains(Achat.Range("b" & i).Value) Then _ .Add Achat.Range("b" & i).Value Next End With For i = 0 To Col.Count - 1 '----------------------------- laste_D = Detail.Cells(Rows.Count, 1).End(3).Row If laste_D% <> 1 Then laste_D% = laste_D% + 2 '========================= Fter_Rg.AutoFilter 2, Col.Item(i) Fter_Rg.SpecialCells(12).Copy _ Detail.Range("a" & laste_D%) Next Fter_Rg.AutoFilter Col.Clear '========================= By_Date.Cells(1, 1).Resize(, 2) = my_arr2 For i = 2 To lr1 If Not Col.contains(Achat.Range("d" & i).Value) Then _ Col.Add Achat.Range("d" & i).Value Next '========================= For i = 0 To Col.Count - 1 For k = 2 To Fter_Rg.Rows.Count If Achat.Range("D" & k) = Col.Item(i) Then By_Date.Range("b" & i + 2) = Col.Item(i) s = s + Achat.Range("C" & k) End If Next By_Date.Range("A" & i + 2) = s s = 0 Next '=================== End Sub الملف مرفق _salimجدول الشراء.xlsm

تفضل هنا مطلوبك

السلام عليكم في حدث مفتاح للاسفل للنموذج ضع هذا الكود: If KeyCode = vbKeyF6 Then DoCmd.OpenForm "نموذج6" End If كما يجب أن تغير خاصية مفتاح المعاينة إلى نعم في خصائص هذا النموذج

وعليكم السلام كان عليك من البداية استخدام خاصية البحث فى المنتدى - تفضل https://www.officena.net/ib/topic/27773-اضافة-ملف-او-ملفات-صوتية-الي-ملف-اكسل/ كما ان هناك عدة فيديوهات لهذا الأمر https://www.youtube.com/watch?v=aPagfyX_SCU https://www.youtube.com/watch?v=Z18CpWlKhKg https://www.youtube.com/watch?v=WgpNay0AzBg

قصدت من سؤالي هو محاولة معالجة الكود الاول تفضل الكود الآخر ويعمل على اكمل وجه db3.rar

مشكور أخي يحيى وتكملة للمشوار ولهذا الغرض قمت بتصميم هذه الدالة للإخوة الذين يستعملون نسخ سابقة عن أوفيس 2007 و 2010 Function masround(n As Double, m As Double) As Double masround = IIf(n - m * (n \ m) >= m / 2, m * (n \ m + 1), m * (n \ m)) End Function وكل عام أنتم بخير

السلام عليكم و رحمة الله اضافة لحل الاخ خالدي جرب هذه المعادلة =MROUND(12122,25) قم بإستبدال الرقم 12122 بمرجع اي خلية و هي تعمل بشكل ماشر مع نسخة 2007 و 2010 من الاكسيل و في النسخ القديمة يجب تثبيت Analysis ToolPak ======== دمتم في حفظ الله