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

جرب هذا الملف Example.xlsm

المعادلة لا تقوم بازاحة الصفوف من مكانها و ريثما تقوم شركة مابكروسوفت باحتراع هكذا معادلة علينا فقط استعمال الــ VBA الكود Option Explicit Sub Get_Std_Names() Dim G As Range Dim H As Range Dim Ro_All%, ro_H%, i%, m%, n% Dim str$ str = "غ" Ro_All = ALL.Cells(Rows.Count, 2).End(3).Row If Farz.Range("b1").CurrentRegion.Rows.Count > 1 Then Farz.Range("b1").CurrentRegion.Offset(1). _ Resize(Farz.Range("b1").CurrentRegion.Rows.Count - 1). _ Clear End If For i = 2 To Ro_All If Application.CountIf(ALL.Cells(i, 3).Resize(, 6), str) = 0 Then m = m + 1 If G Is Nothing Then Set G = ALL.Cells(i, 2).Resize(, 7) Else Set G = Union(G, ALL.Cells(i, 2).Resize(, 7)) End If Else n = n + 1 If H Is Nothing Then Set H = ALL.Cells(i, 2).Resize(, 7) Else Set H = Union(H, ALL.Cells(i, 2).Resize(, 7)) End If End If Next G.Copy Farz.Cells.Cells(2, 2) Farz.Range("a2").Resize(m) = _ Evaluate("Row(" & 1 & ":" & m & ")") H.Copy Farz.Cells.Cells(m + 2, 2) Farz.Range("A" & m + 2).Resize(n) = _ Evaluate("Row(" & 1 & ":" & n & ")") Farz.Range("A2").Resize(m + n). _ Borders.LineStyle = 1 Farz.Range("B1").CurrentRegion.Offset(1). _ Resize(Farz.Range("B1").CurrentRegion.Rows.Count - 1). _ InsertIndent 1 End Sub الملف مرفق Third_class.xlsm

السلام عليكم ورحمة الله جرب هذا الكود Sub Add_Data() Dim ws As Worksheet, Arc As Worksheet Dim LR As Long Set ws = Sheets("hassila") Set Arc = Sheets("Archives") LR = Arc.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A7:D" & ws.Range("A" & Rows.Count).End(xlUp).Row).Copy Arc.Activate Arc.Range("A" & LR + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False ' :اذا اردت مسح البيانات من الورقة الاولى قم بازالة العلامة التى على اليسار من العبارة التالية 'ws.Range("A7:D" & ws.Range("A" & Rows.Count).End(xlUp).Row-1).ClearContents End Sub

وعليكم السلام ورحمة الله وبركاته جرب هذا لعله بيفي الغرض تم إضافة كود إضافة وحدف الدوائر إلى كود الترحيل الدواءر الحمراء.xlsb

تفضل ضع هذه المعادلة لاستخراج الارقام الى الخلية المجاورة ثم اجمع مثال.xlsx

استاذ أحمد لا ضرورة لعمل حلقة تكرارية حتى 1000 صف (أكثر من 900 فارغ) بالاضافة الى شروط IF لوضع التسلسل (أرهاق اضافي للبرنامج) يكفي اضافة ما موجود في المربع الأزرق من هذه الصورة

بعد اذن احي أحمد بدره هذا الكود ربما يكون اسهل قليلاً (الشيت 3) Option Explicit Sub Get_data() Dim S As Worksheet Dim T As Worksheet Dim cret_rg As Range Dim col% Dim s_rg As Range Set S = Sheets("Sheet2"): Set T = Sheets("Sheet3") Set s_rg = S.Range("A1").CurrentRegion If T.Range("B3").CurrentRegion.Rows.Count > 1 Then T.Range("B3").CurrentRegion.Offset(1). _ Resize(T.Range("B3").CurrentRegion.Rows.Count - 1).Clear End If If s_rg.Rows(1).Find(T.Range("H1"), lookat:=1) Is Nothing Then Exit Sub col = s_rg.Rows(1).Find(T.Range("H1"), lookat:=1).Column With T .Range("B3") = S.Range("A1") .Range("C3") = S.Range("B1") .Range("D3") = T.Range("H1") .Range("H2") = "غ" Set cret_rg = .Range("H1:H2") s_rg.AdvancedFilter 2, cret_rg, .Range("B3:D3") .Range("H2") = "" End With End Sub الملف مرفق Class_3.xlsm

وعليكم السلام-يمكنك استخدام هذه المعادلة ابتداءاً من الخلية M5 سحباً للأسفل =INDEX($E5:$J5,MATCH($K5,$E$4:$J$4,0))/$L5 الاداري1.xls

لمعرفة الطريقة شاهد هذا الفيديو لطفا

العفو اخى والشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا اتفضل التعديل ان شاء الله يكون كما طلبت سيتم احتساب الوقت عند فتح النموذج وتسجيل المواعيد واضافه 5 دقائق تم استخدام متغير عام على مستوى النموذج من نوع تاريخ Dim nowLogin As Date ثم فى حدث عند التحميل وضعت الكود Private Sub Form_Load() nowLogin = Format(Now(), "Medium Time") End Sub ثم فى حدث بعد التحديث لحالة الكشف Private Sub حالة_الكشف_AfterUpdate() 'nowLogin متغير ' ld متغير Dim ld ld = DLast("[وقت الحضور]", "[الكشف]", "[تاريخ]=#" & Me.تاريخ & "#") If IsNull(ld) Then Me.[وقت الحضور] = DateAdd("n", 5, nowLogin) Else Me.[وقت الحضور] = DateAdd("n", 5, ld) End If End Sub بالنسبه ل ld فهو متغير ويمكنك الاستغناء عنه بالنسبه للشروط فهو شرط 1 التاريخ = التاريخ ان شا الله اكون وفقت لشرح ما تريد بالتوفيق اخى حساب الوقت_1.accdb

تفضل هذه المشاركة FILES.accdb

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

وعليكم السلام ورجمة الله وبركاته في حقل الفلتر اضف السطر التالي .Filters.Add "Excel Files", "*.*" تحياتي

عليكم السلام و رحمة الله و بركاتة تفضل اخى الكريم اتمنى ان يكون هذا طلبك TEST (1).xlsx

الآن استطيع ان اعطيك الكود الصحيح Option Explicit Private Sub Worksheet_Activate() Salim_Data_Val End Sub Rem+++++++++++++++++++ Sub Salim_Data_Val() Dim B As Worksheet Set B = Sheets("البيانات الرئيسية") Dim i#: i = 7 Dim Laste_row# Laste_row = B.Cells(Rows.Count, "N").End(3).Row B.Range("AL7").Resize(Laste_row + 1).ClearContents Dim rg As Object Set rg = CreateObject("System.Collections.Arraylist") With rg Do Until i > Laste_row-6 If Not .Contains(UCase(B.Range("N" & i).Value)) _ And B.Range("N" & i) <> vbNullString Then _ .Add UCase(B.Range("N" & i).Value) i = i + 1 Loop .Sort B.Range("AL7").Resize(.Count) = _ Application.Transpose(.Toarray) End With Set rg = Nothing: Set B = Nothing End Sub

ادرج الصيغة التالية كما في المرفق =CONCATENATE(B2;" ";TEXT(A2;"00%")) سليم.xlsx

اجعل المعادلة هكذا =B2&""&A2*100&"%" 1سليم.xlsx

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم صورة الصنف.rar تحياتي

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

هذا الخطأ بالتقريب موجود في برنامج الاكسل وغيره من البرامج، والسبب كما يقولون هو التقريب الحاصل نتيجة تخزين الأرقام العشرية بالكمبيوتر بصيغة الرقم الثنائي binary number ويمكن ملاحظة ذلك في المثال التالي: والمتحدثون عن ذلك يقترحون حلين: 1- استخدام الدالة round لتخطي خطأ التقريب 2- التعديل بخيار الاكسل لاعتبار العدد كما هو ظاهر وتجاهل الدقة غير المعروضة بعد تعديل الخيارات، ظهرت النتيجة للمزيد ممكن الاطلاع على: https://docs.microsoft.com/ar-sa/office/troubleshoot/excel/floating-point-arithmetic-inaccurate-result https://www.microsoft.com/en-us/microsoft-365/blog/2008/04/10/understanding-floating-point-precision-aka-why-does-excel-give-me-seemingly-wrong-answers/ بالتوفيق

وبالاضافة إلى ما تفضل به استاذنا يمكن عملها يدويا عن طريق التنسيق الشرطي ->قواعد تمييز الخلايا -> القيم المتكررة ثم اختيار التنسيق المطلوب وبالتوفيق تلوين خلايا نطاق.xlsx

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

قم بفتح كل من مستند Word وورقة عمل Excel الذي يحتوي على البيانات التي تريد إنشاء كائن مرتبط أو مضمن منها. قم بالتبديل إلى Excel، ثم حدد ورقة العمل بأكملها أو نطاقاً من الخلايا أو المخطط الذي تريده. اضغط فوق CTRL+C. قم بالتبديل إلى مستند Word، ثم انقر فوق المكان حيث تريد ظهور المعلومات. في علامة التبويب الصفحة الرئيسية، في المجموعة الحافظة، انقر فوق السهم الذي تحت لصق، ثم انقر فوقلصق خاص. في القائمة كـ حدد Microsoft Office Excel كائن. انقر فوق لصق لإدراج كائن مضمن، أو انقر فوق لصق الارتباط لإدراج ارتباط إلى الكائن و الخطوات من word الى excel هى نفس الطريقة لكن لصق من word الى excel

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