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

تفضل يمكنك جعل المعادلة هكذا ... وتم عمل أيضاً تنسيق شرطى للخلية اذا كان بها كلمة مغادرة =IF(G$7=$D8,"مغادرة",IF(AND(G$7>=$C8,G$7<=$D8-1),$E8,0)) If Function.xlsx

للتنويه : يمكن عمل ذلك باكثر من طريقة مثلا تعمل جدول مشابه للجدول الاساسي وتجعل حق الاسم مطلوب .. التكرار لا ثم تعمل استعلام الحاق من الجدول الاساسي للجدول الجديد . فيتم استبعاد الاسماء المكررة ... وهكذا

هذا واجب علينا للمنتدى واعضائه حياك الله اخي الكريم

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

جرب المرفق وخبرنا بالنتيجة ..... fouad.accdb

طيب على اي اساس تريد حذف السجل المكرر ... هل اول سجل يحذف والاخر يبقى ... لانك تقول البيانات الاخرى مختلفة مثلا محمد البرناوي لديه سجلات عديدة وحقل الهاتف لدية رقم هاتف رقم ١ وفي السجل الاخر رقم هاتف اخر رقم ٢ ؟؟؟؟ كيف يتم الحذف ... ماهو الاساس .... ام تريد سجل واحد بغض النظر الى تلك الحقول الاخرى ؟؟

وعليكم السلام test.accdb

شوف يكون معاك ملف خطوط تستخدمه ويكون موجود مع ملف البرنامج ويتم تنصيبه لدى العميل انا شخصيا بعمل كده

@husamwahab, @Shivan Rekany كلمة شكر لاتكفي لكن دعوة بالغيب ,,,,,,

اتفضل اليك هذا استعلام SELECT Root() AS Exprt1; اليك ملفك بعد اضافة استعلام Root2211.rar

تفضل التعديل ارجو ان يكون طلبك Root2211.rar

جزيل الشكر استاذ شفان وهو المطلوب

وعليكم السلام حياك الله شاهد هذا الموضوع للأستاذ @SEMO.Pa3x :

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

try this file WiAAM.xlsx

جرب هكذا وهناك ايضا فيديو لشرح عملية التحويل للأستاذة ساجدة العزاوى لها منا كل الإحترام ج100 كيف نجعل كود 32 بت يعمل على 64 بت وعدم ظهور خطأ ptrsafe اكسل vba ساجدة العزاوي تحويل64بيت.xlsb

Dim Numbers if len(SText & "")=0 then GetNumbersOnly="" exit function end if For i = 1 To Len(SText) If IsNumeric(Mid(SText, i, 1)) and Mid(SText, i, 1) <> 0 Then Numbers = Numbers & Mid(SText, i, 1) End If Next GetNumbersOnly = Trim(Numbers) اتفضل تم اضافة هذا جزء فقط and Mid(SText, i, 1) <> 0

ABO.xlsm

هل تريد الترحيل عندما تكون حصيلة اليوم فارغة ؟ على كل استبدل الكود بهذا لمعالجة المشكلة Sub test() Dim a As Variant Dim i With Sheets("MainSheet") On Error Resume Next a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1) If UBound(a) Then With Sheets("DataSheet") For i = 1 To UBound(a) .Cells(i + 1, 3) = .Cells(i + 1, 3).Value + a(i, 1) Next End With End If .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1).ClearContents End With End Sub

عيسى العامري أين انت من كل هذه الإجابات الممتازة؟!!! لم أرى اى ضغط على الإعجاب من طرفك , وهل جزاء الإحسان الا الإحسان ؟!!!! أين الضغط على الإعــــجـــــاب , وكما اتفقنا ان هذا أقل ما يقدم لمن له الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!! 💙

هكذا؟ وعلىفرض أن ترتيب الأسماء في الشيتين هو نقسه تماما ABO.xlsm

شكرا للسائل شكراً استاذ حسام انا ايظاً كنت بحاجة لهذا الموضوع

May be? الصيغة الاصلية للكشف البنكي.xlsm

بارك الله فيك استاذ محي ولإثراء الموضوع يمكنك استخدام هذه المعادلة المعرفة وهذا هو كودها Function Evals(t As String) As Double Dim c As String, i As Long For i = 1 To Len(t) If Asc(Mid(t, i, 1)) < 58 And Asc(Mid(t, i, 1)) > 41 Then c = c & Mid(t, i, 1) Next Evals = Evaluate(c) End Function ثم تكتب المعادلة بالخلية B2 على النحو التالى : =Evals(A2) سليم1.xlsm

ما رأيك بهكذا سليم.xlsm

جرب المرفق لعله يفي بالغرض المصنف1( (1).xlsm

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

حسب المثال مثال لدي في العمود aعدد من ارقام الصنف بالترتيب بفرض الرغبة في تجزئة اراقم الصنف على عدد اربع خانات الخانة الاولى رقمين الخانة الثانية ثلاث ارقام الخانة الثالثة ثلاث ارقام الخانة الرابعة ثلاث ارقام مثال الاجابة يمكن ذلك باستخدام اداة فصل النص على اعمدة الخطوات 1- تحديد خلايا الارقام المطلوب فصلها 2- الذهاب الى قائمة بيانات واختار اداة " النص الى اعمدة " 3- نختار خيار عرض ثابت ثم نضغط .>>>>>>التالي 4- نقوم بالتحديد بمؤشر الفارة الارقام التي نرغب في فصلها نضغط بعد الرقمين الاوائل يظهر لنا سهم الفصل ثم نضف' بعد ثلاث ارقام ثم نضغط بعد ثلاث ارقام ثم نضغط .>>>>>>التالي 5- ثم نضغط .>>>>>> انهاء سيظهر الرقم كالتالي في الاعمدة D C B A 220 100 100 56 *** ايضا يمكن استخدام ذلك مع النصوص

و هذا ملف يمكنك منه خلاله الاختيار دمج الخلايا او عدم دمجها زر لكل اختيار (على 3 أعمدة (يمكن الاضافة قدر ما تريد) Option Explicit Sub Unmerg_cells() Application.ScreenUpdating = False If ActiveSheet.Name <> "Test" Then GoTo End_Me Dim lr#, i# Dim My_rg As Range, x, y, z, n Dim My_min lr = Cells(Rows.Count, "A").End(3).Row For i = 2 To lr If Cells(i, 1).MergeCells Then x = Cells(i, 1) y = Cells(i, 2) z = Cells(i, 3) n = Cells(i, 1).MergeArea.Rows.Count Cells(i, 1).UnMerge Cells(i, 1).Resize(n) = x Cells(i, 2).UnMerge Cells(i, 2).Resize(n) = y Cells(i, 3).UnMerge Cells(i, 3).Resize(n) = z i = i + n - 1 End If Next End_Me: Range("A1").Select Application.ScreenUpdating = True End Sub '++++++++++++++++++ Sub merge_all() Application.ScreenUpdating = False If ActiveSheet.Name <> "Test" Then GoTo End_Me Dim k% For k = 1 To 3 Call One_for_all(k) Next With Range("A1").CurrentRegion .Font.Size = 14 .Font.Bold = True End With End_Me: Range("A1").Select Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++ Sub One_for_all(ByVal Col As Integer) Application.DisplayAlerts = False Dim i%, lr%, My_rg As Range Dim x lr = Cells(Rows.Count, Col).End(3).Row Set My_rg = Cells(1, Col) For i = 1 To lr x = Cells(i, Col).Value If My_rg.Cells(1).Value = x Then Set My_rg = Union(My_rg, Cells(i, Col)) My_rg.MergeCells = True Else Set My_rg = Cells(i, Col) End If Next Application.DisplayAlerts = True End Sub الملف مرفق Merge_Unmerge_rows_Multiple_colmns.xlsm

الماكرو يتعاطى مع الخلايا المدمجة في اول ثلاثة اعمدة فقط الخلابا العادية ليس لها شأن

جرب هذا الكود Option Explicit Sub Unmerg_cells() If ActiveSheet.Name <> "ورقة1" Then Exit Sub Dim lr#, i# Dim My_rg As Range, x, y, z, n Dim My_min lr = Cells(Rows.Count, "D").End(3).Row For i = 2 To lr If Cells(i, 2).MergeCells Then x = Cells(i, 1) y = Cells(i, 2) z = Cells(i, 3) n = Cells(i, 2).MergeArea.Rows.Count Cells(i, 1).UnMerge Cells(i, 1).Resize(n) = x Cells(i, 2).UnMerge Cells(i, 2).Resize(n) = y Cells(i, 3).UnMerge Cells(i, 3).Resize(n) = z My_min = Application.Min(Range("d" & i).Resize(n)) Range("d" & i).Resize(n) = Format(My_min, "d/m/yyy") i = i + n - 1 End If Next End Sub الملف مرفق Gorh.xlsm

السلام عليكم, في السابق كنت استخدم خطوط معينة في برامجي وعند اعطاء البرنامج للعميل لاتظهر الخطوط التي قمت باستخدامها بل يظهر بمكانها الخط ( Arial ) وهذه مُشكلة. كت في وقتها الجأ الى ان اضع الخط بجانب قاعدة البيانات وفي داخل قاعدة البيانات اقوم بعمل تحقق لمجلد Fonts والبحث عن الخط في بداية تشغيل القاعدة, فإن لم يجده يعي رسالة للعميل بان الط مفقود وعليه ان يقوم بتثبيته من جانب البرنامج. بحثت طويلاً في الانترنت عن تثبيت خط من الاكسس فقط بدون مساعدة عامل خارجي ولكن لم اصل لنتيجة. اليوم بحمد الله قمت بحل المشكلة بإستخدام ( Visual .NET ) قمت بكتابة اداة بسيطة وظيفتها تثبيت الخط. يتم تمرير براميتر لها وهي بدورها ستقوم بتثبيته الدوال المستخدمة: AddFontResource CreateScalableFontResource ShellExecuteA للمزيد من المعلومات ، اضغط على اسم الدالة ارفقت لكم المصادر من MSDN شرح بسيط لمن لم يعرف ماذا اقصد بتثبيت الخط واستخدام الخط وانه لن يظهر في حال كان العميل لا يملكه. قمت بارفاق قاعدة بيانات لكم كـ مثال للشرح مع الخط المستخدم مع الاداة. شرح الاستعمال: يجب ان تكون الاداة ( SEMO_RegisterFont.exe ) هي والخط الذي سوف تستخدمه بجانب قاعدة البيانات. افتح برنامجك وضع فيه هذا الاجراء. Sub RegisterFont(nFont) Dim strExe As String Dim strArg As String strExe = CurrentProject.Path & "\" & "SEMO_RegisterFont.exe" strArg = "/SEMO/" & nFont ShellExecute 0, "runas", strExe, strArg, vbNullString, SW_SHOWNORMAL End Sub في الاستدعاء اي في الحدث Form_Current RegisterFont "DroidSansArabic.ttf" حيث ان الـ DroidSansArabic.ttf هو اسم الخط الذي قمنا بوضعه بجانب قاعدة البيانات ملاحظة مهمة جدا: في حال كان اسم الخط يتكون من اكثر من كلمة مثل ( Droid Sans Arabic.ttf ) قم بحذف المسافات بين كلمة واخرى بحيث يصبح ( DroidSansArabic.tts ) وستعمل قاعدة البيانات التي قمت بتصميمها بشكل رائع وبالخطوط التي قمت انت بأختيارها بدون الخوف من مشكلة عدم توفر الخطوط في جهاز العميل. الشرح حصري للمنتدى وغير موجود في الانترنت. لا تشكرني الا اذا وجدت انني استحق ذلك. تم بحمد الله حسنين RegisterFont_SEMO_Pa3x.rar

أخي نزار بعد اذنك لقد قمت بعمل شرح تفصيلي لطريقة عمل هذه الميزة في الاكسيل و ذلك نظراً لحساسية بعض النقاط في عمل هذه الميزة و يمكن لجميع الأخوة الحصول على الشرح من خلال هذا الرابط http://www.officena.net/ib/index.php?showtopic=28736 و دمتم بحفظ الله و رعايته