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

في الخلية هذه المعادلة C5 وتسحب يساراً (تنسيق الخلية General ) =MONTH(DATE($B$1,$B$2+COLUMNS($A$1:A1)-1,$B$3)) في الخلية C9 هذه المعادلة (تنسيق الخلية General ) =DAY(DATE($B$1,$B$2,$B$3+COLUMNS($A$1:A1)-1)) بالنسبة لدمج الخلابا فالمعادلات لا تقوم بهذا الشيء (فقط الماكرو)

وعليكم السلام ورحمة الله وبركاته برجاء مراجعة المرفق colmn.accdb تحياتي

وعليكم السلام بالتأكيد اخى الكريم لا يوجد دالة لذلك ,فقط يمكنك الدخول الى قاموس جوجل والترجمة مباشرة https://translate.google.com.eg/?hl=ar#view=home&op=translate&sl=en&tl=ar&text=الفعلى والا لو لديك ملف الإكسيل يحتوى على قاعدة بيانات بها جميع الأسماء التى تحتاجها وتريدها فى هذه الحالة فقط يمكنك استخدام معادلة بحث عند الإحتياج لذلك

ساعة رقمية بالاكسل الفيديو

عجبنى الموضوع ده قلت أشاركه معكم بإختصار هو سكريبت لعمل مكان موثوق لملفات الأكسيس من مكان تشغيله .. بمعنى لو شغلته من Desk Top تقدر تفتح أى ملف أكسيس على Desk Top بدون ظهور Enable Content. ولو عندك فولدر لمشاريعك فى أى مكان سواء سى أو دى أو .... ضع هذا السكريبت داخله وشغل وخلاص بقى كل ما بداخل الفولدر منطقة أمان. إنشئ ملف نص بأى إسم وضع فيه ما يلى على أن تغير إمتداده الى vbs. Const HKEY_CURRENT_USER = &H80000001 Dim oRegistry Dim sPath Dim sDescription Dim bAllowSubFolders Dim bAllowNetworkLocations Dim bAlreadyExists Dim sParentKey Dim iLocCounter Dim arrChildKeys Dim sChildKey Dim sValue Dim sNewKey Set WshShell = CreateObject("WScript.Shell") strCurDir = WshShell.CurrentDirectory Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv") sPath = strCurDir sDescription = "YourTrustedLocationDescriptionGoesHere" bAllowSubFolders = True bAlreadyExists = False sParentKey = "Software\Microsoft\Office\16.0\Access\Security\Trusted Locations" ' sParentKey = "Software\Microsoft\Office\16.0\Excel\Security\Trusted Locations" ' sParentKey = "Software\Microsoft\Office\16.0\PowerPoint\Security\Trusted Locations" ' sParentKey = "Software\Microsoft\Office\16.0\Word\Security\Trusted Locations" iLocCounter = 0 oRegistry.EnumKey HKEY_CURRENT_USER, sParentKey, arrChildKeys For Each sChildKey in arrChildKeys oRegistry.GetStringValue HKEY_CURRENT_USER, sParentKey & "\" & sChildKey, "Description", sValue If sValue = sDescription Then bAlreadyExists = True If CInt(Mid(sChildKey, 9)) > iLocCounter Then iLocCounter = CInt(Mid(sChildKey, 9)) End If Next 'If bAlreadyExists = False Then sNewKey = sParentKey & "\Location" & CStr(iLocCounter + 1) oRegistry.CreateKey HKEY_CURRENT_USER, sNewKey oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Path", sPath oRegistry.SetStringValue HKEY_CURRENT_USER, sNewKey, "Description", sDescription If bAllowSubFolders Then oRegistry.SetDWORDValue HKEY_CURRENT_USER, sNewKey, "AllowSubFolders", 1 End If كما يمكن تفعيله للاكسيل والوورد والباور بوينت مع مراعاة نسخة الاوفيس لديك وتغيرها فى الكود: أوفيس 2019 : 16.0 أوفيس 2016 : 16.0 أوفيس 2013 : 15.0 أوفيس 2010 : 14.0 أوفبس 2007 : 12.0 أوفيس 2003 : 11.0 أظن أنه لا يوجد أحد أعضاء منتدانا الكريم يعمل على أوفيس XP 😊 عسى أن يفيد .. إذا اشتغل يعنى والله الموفق EAR TrustAnyWhere.zip

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

تفضل اخي الكريم كما بالصورة تحياتي

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

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

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

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

شكرا لك أخي سأجرب

اولا من فضلك لو تحافظ علىقوانين المنتدى بوضع عنوان مناسب ليكون افضل لمن يبحث من بعدك عن نفس الالية الحل ان تريد فتح الاستعلام من خلال قيمة معلمة من نموذج Between Nz([forms]![frmName]![txtFromDat],"01/01/1900") And Nz([forms]![frmName]![txtToDate],"01/01/2100") الحل ان اردت فتح الاستعلام من خلال قيمة معلمة بدون نموذج Between Nz([FromDat],"01/01/1900") And Nz([ToDate],"01/01/2100")

انصحك بهذا الملف كي تعمل عليه لانه يحدد لك كل الايام بين تاريخين مع عدم ادراج العطل الاسبوعية ( سبت ,احد, جمعة الخ ...) والعطل الرسمية او القسرية) Working_days_2019.xlsm

شكراً على المرور اخ أحمد الفلاحجى لايتطابق مع ما اوريد

تفضل اخي حسين يمكنك الآن ادخال ارقام من باركود او يدوي ولكن عند ادخال يدوي عليك ضغط على زر انتر سواء من نموذج او من كيبورد Test1.accdb

take look My_Month.xlsx

اخي حسين مامون مبارك اتمنى لك توفيق

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

اتوجه بالشكر الى شخصكم الكريم الاستاذ shetosalex والاستاذ سليم على مروركم الرائع وهذا الحل فى منتهى العبقرية والى الاستاذ احمد بدره بكل الحب والوفاء وبأرق كلمات الشكر والثناء، ومن قلوب ملؤها الإخاء أتقدم بالشكر والثناء الى الاستاذ سليم لوقوفك إلى جانبي ولم يتبقى سوى نقطة دمج الشهور

الف مبارك اخينا حسين مامون نسأل الله ان ان تكون نبراسا بهذا المنتدي

بارك الله فيك أستاذنا الفاضل سليم

ألف مبروك وبالتوفيق دائمًا وأسأل الله العظيم أن يعينك على هذه المسئولية

الف مليون مبروك بالتوفيق

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

اخواني اساتذتي Ali Mohamed Ali و سليم حاصبيا واخرون ، انه لشرف لي ان أكون بين عظماء مثلكم واتمنى من العلي القدير ان ينور قلوبنا وان يتقبل منا ومنكم جميع اعمالنا وان نكون عند حسن ظن جميع اعضاء هذا الصرح العظيم. اشكركم جميعا تحياتي

ألف مبروك استاذ حسين مأمون وان شاء الله معاَ الى ما أبعد من الواجب

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

فين شرح المطلوب ؟!!! وفى اى يعمود تريد وضع المعادلة , كيف تقوم برفع مشاركة بدون شرح المطلوب بكل دقة ووضع النتائج المتوقعة والمطلوبة !!!!!!!!!!

السلام عليكم أولا أشكرك أخي الكريم الحقيقة ان هناك نوعين من التعليمات ، التعليمات المختصرة التى ذكرتها و التي بها اهم واعم ما ينطبق و الوصلة الموجودة فى اعلى الجزء المختصر و بها تعليمات تفصيلية و ملونة https://www.officena.net/Tips/Questions.htm اما الاقتباس فهو احيانا محمود حين يتم تحديد جزء معين من المشاركة للرد عليه اما الاقتباس الكامل فهو غير مفيد و يجب تجنبه و هذه الجزئية فعلا غير مغطاة فى قواعد المشاركة ، و سيتم تداركها باذن الله مع التعديل القادم

أ.حسين العربى جرب المرفق عسى يكون المطلوب test (2).accdb

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

أولاً استبدل كلمة sheets بكلمة Worksheets ثانيًا الفورم الخاص بورقة العمل البيانات كان فيه تكست بوكس اسم تكست بوكس غير موجود بالفورم أي أن التكست بوكسات غير مرتبة فتم إعادة تسمية التكست بوكسات التي كانت في غير ترتيبها حتى يتم البحث بشكل سليم ثالثًا مرفق الملف بعد التعديل بيانات العملاء.xlsm

تلوين اسماء الشيتات بضغطة واحدة لاى عدد من الشيتات الفيديو

قم بتعديل الكود او انسخ الجزء بين السطرين فقط واضفه للكود عندك Private Sub CommandButton1_Click() ' saveas_facture() Dim wx As Workbook Set wx = Workbooks("ÝÇÊæÑÉ") Dim ws As Worksheet Set ws = wx.Sheets("invoice") Dim wss As Worksheet Set wss = wx.Sheets("sheet1") Dim DT Dim Nam Dim lr As Long Application.ScreenUpdating = False Application.EnableEvents = False lr = wss.Range("a" & Rows.Count).End(xlUp).Row + 1 DT = ws.Range("e5") & Format(Now(), "dd-mm-yyyy hh mm ss") With ws ' .Copy ' .UsedRange = .UsedRange.Value Application.DisplayAlerts = False ' Nam = "d:\back\backup\ÝÇÊæÑÉ" & DT & ".xlsx" Nam = .Range("e5") & " " & Format(Now(), "dd mm yyyy hh mm ss") ThisWorkbook.SaveCopyAs Filename:="D:\back\Backup\" & Nam & ".xlsm" ' ActiveWorkbook.SaveAs Nam, FileFormat:=xlOpenXMLWorkbook '========================================= If ws.[f5].Text = "اجل" Then wss.Range("a" & lr).Value = Nam wss.Range("a" & lr).Font.Color = 255 Else: wss.Range("a" & lr).Value = Nam End If '======================================== ' ActiveWorkbook.Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "Êã ÍÝÙ äÓÎÉ ÈÇÓã " & DT & " ", vbInformation End Sub

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

وعليكم السلام اخي الكريم ممكن دلك ولكن يحتاج الموضوع للبحث الموسع لانه توجد عدة اجهزة للبصمة اجهزة البصمة انواع . وبصفة عامة هي نوعين .. داتا وريدر فالداتا لها نظامها الخاص مثل جهاز الكمبيوتر الذي امامي وتستخدم على نطاق واسع في الحضور والانصراف وتدعم الشبكات ويمكن من خلالها الاطلاع على حضور وانصراف موظفي . اما النوع الثاني فهو يتعامل مع الواجهات انترفيس ويستخدم في الحماية والمقارنة ويستخدم كثيرا في الصلاحيات والابواب ونحو ذلك . واخلص الموضوع ان كل نوع من البصمات له اكواده الخاصة للربط مع لغات البرمجة تنتجها الشركة المصنعة وتوزعها مع منتجاتها وهذا يفسر السبب في عدم وجود دروس وافية عن هذا الموضوع لانه يتطلب من المتعلم التطبيق على جهاز مشابه لما في الدرس وهدا رابط لموضوع البصمة للاستادة زهرة ممكن ان تجد فيه ظالتك وهدا موضوع تم طرحه من قبل الاستاد الفاضل علي العتيبي (startnet ) اخواني بعد الاطلاع على الكثير من مواضيع التعامل مع جهاز البصمه و البحث حول هذا الموضوع اتضح لي انه لا يوجد اي موضوع يتعلق بجهاز البصمه و كيف التعامل معه من خلال الاكسس كل المواضيع تتكلم عن خطوط عريضه ولا يوجد اي مثال حقيقي لذلك ولم اجد اي موضوع وصل صاحب السؤال الى هدفه اذا كان هناك احد تعامل مع جهاز البصمه بحيث عند عمل بصمه في الجهاز تظهر مباشره بيانات الموظف رقمه او اسمه او تاريخ او وقت دخوله في نموذج اكسس ثم تتخزن في قاعده البيانات يرفق لنا المثال حتي يستفيد الجميع منه انا شريت جهاز zkt ua300 رخيص لغرض التجربه و الاطلاع وحملت التطبيق الخاص به وعملت الاتصال و البصمه وتظهر البيانات مباشره في هذا التطبيق و يتم حفظ البيانات في الجهاز فقط او ممكن تصديرها الي قاعده بيانات اكسس او ملف اكسل او اي صيغه اخرى لكن نريد ان نتعامل مع هذا الجهاز مباشره بدون وسيط طلب من الشركه التي شريت منها الجهاز تزويدي بالعمليه هذه و قدمو لي عرض سعر لا يوجد شي بالمجان :) المبلغ يساوي تقريبا 1000 دولار 300 KD و قيمه الجهاز تقريبا 150 دولار :) 50 KD اصبح البرنامج المطلوب عمله اغلى من قيمه الجهاز بحوالي 7 مرات طبعا العرض غير مقنع و راح يكون هناك وسيط بين جهاز البصمه و برنامج الاكسس مثل السيرفر الداخلي يقراء البيانات كل 30 ثانيه لذلك لم اقتنع بالحل و تركت العرض الان اطلب من الاخوه المشاركه في هذا الموضوع باي افكار او اقتراحات او امثله لعمل ذلك ولا مانع من اي عرض بمقابل مادي الهدف هو معرفه الفكره وهدا رابط ما توصل اليه الاستاد الفاضل علي العتيبي ( ابو فيصل) StartNetZKT.rar وهده تكملة للموضوع المطرح جهاز البصمة الشرح الوافي للاستادة زهرة عبد الله اخي الفاضل ابو مالك السلام عليكم ورحمة الله وبركاته بالنسبة لموضوع بصمة الأصبع فقد تطرقنا له بالشرح التفصيلي وكذلك وضع البرامج اللازمه له ولكن لا يمنع ان اضع بين ايدكم هذا المثال للتطبيق العملي عليه ولكن هناك شروط واجب توفرها لكي يعمل البرنامج بشكل سليم اولا : حاول شراء ( قارئ بصمة الأصبع ) هذا Microsoft Fingerprint Reader وهذه صورته وسعره حوالي 100 ريال سعودي ابحث عنه وستجده في محلات الكمبيوتر التي تبيع الأجهزه ومستلزماتها . ويكون المنفذ الخاص به هو USB ثانيا : بعد الحصول عليه لا تقوم بتركيب قارئ بصمة الأصبع في جهازك حتى تقوم بتنصيب هذا البرنامج اولا VeriFinger_6_0_Extended_SDK بعد تثبيت هذا البرنامج والذي يدعم جميع انواع قارئات الأصبع لأن به ملفات DLL تحتاجها كل اجهزة قارئة الأصبع Microsoft Fingerprint Reader Microsoft Wireless IntelliMouse Explorer with Fingerprint Reader Microsoft Optical Desktop with Fingerprint Reader DigitalPersona U.Are.U 4000 DigitalPersona U.Are.U 4000B Testech Bio-I CYTE Secugen Hamster III M2SYS M2-S Fingerprint Reader Biotouch / Futronic FS80 Nitgen Hamster I / Hamster II Certis Image Orcanthus Crossmatch V250 / V300 / V300 LC / V300 LC2 / V500 طبعا من ضمنها جهازنا Microsoft Fingerprint Reader الذي قمنا بشرائه ثالثا : قم بتركيب جهاز قارئة الأصبع من خلال المنفذ USB وسوف يتعرف عليه نظام الويندوز اذا كان محدث وإلا سوف يطالبك بعمل تحديث من موقع مايكروسوفت لهذا الجهاز رابعا : وهو المهم هذا برنامج معمول بالأكسيس لهذا الغرض وتأكد جيدا من وجود المكتبه في المراجع كما في الصوره وموقعها في جهاز الكمبيوتر لديك وإلا سوف يظهر لك خطأ عدم وجود المراجع البرنامج GrFinger.rar

اخواني الأعضاء الأساتذة الأحباء في المنتدى خلال بحثي عن دود الادخال الى أوراق الأشهر وجدتو ان تسمحو لي ان اقدم لكم كودان لانشاء أوراق العمل بأسماء الأشهر واحد للغة الانكلزيه والأخر ععمل حسب لغة الحاسوب المستخدم ارجو ان يستفيد الاخوة منه وتقبلو تحياتي اللغة الانكلزية Sub DoMonths() Dim J As Integer Dim K As Integer Dim sMo(12) As String sMo(1) = "January" sMo(2) = "February" sMo(3) = "March" sMo(4) = "April" sMo(5) = "May" sMo(6) = "June" sMo(7) = "July" sMo(8) = "August" sMo(9) = "September" sMo(10) = "October" sMo(11) = "November" sMo(12) = "December" For J = 1 To 12 If J <= Sheets.Count Then If Left(Sheets(J).Name, 5) = "Sheet" Then Sheets(J).Name = sMo(J) Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sMo(J) End If Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = sMo(J) End If Next J For J = 1 To 12 If Sheets(J).Name <> sMo(J) Then For K = J + 1 To Sheets.Count If Sheets(K).Name = sMo(J) Then Sheets(K).Move Before:=Sheets(J) End If Next K End If Next J Sheets(1).Activate End Sub مختلف اللغات Sub DoMonths() Dim J As Integer Dim K As Integer For J = 1 To 12 If J <= Sheets.Count Then If Left(Sheets(J).Name, 5) = "Sheet" Then Sheets(J).Name = MonthName(J) Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = MonthName(J) End If Else Sheets.Add.Move after:=Sheets(Sheets.Count) ActiveSheet.Name = MonthName(J) End If Next J For J = 1 To 12 If Sheets(J).Name <> MonthName(J) Then For K = J + 1 To Sheets.Count If Sheets(K).Name = MonthName(J) Then Sheets(K).Move Before:=Sheets(J) End If Next K End If Next J Sheets(1).Activate End Sub الملفات مرفقة اوراق الاشهر بلغة الانكليزية.rar اوراق الاشهر بلغة جهازك.rar

السلام عليكم امثلة على طباعة السجل من (فورم ادخال وتعديل وبحث) الاصدار الثالث http://www.officena.net/ib/index.php?showtopic=51955 هذه ثلاثه امثله مختلفة في المرفق 1 - طباعة في مصنف جديد او من خلال الفورم اذا كانت الشاشة تظهر جميع بيانات السجل 2 - طباعة الى ورقة معينة في الملف حسب تنسيق معين لجميع بيانات السجل 3 - طباعة الى ورقة معينة في الملف حسب تنسيق معين لبعض بيانات السجل المرفقات 2003 فورم ادخال و تعديل مرن مع الطباعة 1.rar

السلام عليكم هو طلب لاحدهم وضعته هنا لعموم الفائدة http://www.officena.net/ib/index.php?showtopic=41089 دائما نكون محتاجين عمودين بجانب النطاق لوضع السيناريو عنوان خلايا الجمع وحاصل نتيجة الجمع غير معطياتك بداية الكود Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" وهذا الكود Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" Dim cd Sub kh_Test() Dim r%, rr% cd = 8 With Range(rAddres) .Interior.ColorIndex = xlNone .Offset(0, 1).Resize(, 2).ClearContents .Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum") For rr = 1 To .Rows.Count For r = rr To .Rows.Count SumTest .Cells, Union(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) Next Next End With End Sub Sub SumTest(MyRng As Range, TestCol As Range, MyVal As Double) Dim iCol As Range, Adr$ With MyRng For Each iCol In .Cells If WorksheetFunction.Sum(Union(iCol, TestCol)) = MyVal Then If kh_tColor(Union(iCol, TestCol)) Then Adr = Union(iCol, TestCol).Address With .Offset(.Rows.Count, 1).End(xlUp).Offset(1, 0) .Resize(1, 2).Value = Array(Adr, "=SUM(" & Adr & ")") End With Union(iCol, TestCol).Interior.ColorIndex = cd cd = cd + 1 Exit For End If End If Next End With End Sub Function kh_tColor(Col As Range) As Boolean Dim T As Range For Each T In Col.Cells If T.Interior.ColorIndex = xlNone Then kh_tColor = True Exit For End If Next End Function المرفق 2003 2007 حاصل جمع.rar ========================================== التحديث الاخير للكود في 18-2-2015 المرفق 2010 سيناريو توافيق تجميع قيم تعطي نتيجة معينة.rar

الاخ على حيدر مشكور على اسهاماتك والكود الجميل الاخ ميدو الكود التالى ينتج أوراق عمل بعدد أيام الشهر مع مراعاة عدد أيام فبراير فى السنة البسيطة والكبيسة مع مراعاة عدد أيام باقى الشهور 30 أم 31 يوما كما ان اسم الورقة عبارة عن ولا أقولك حمل المرفق وشوف اوراق عمل بعدد ايام االشهر الذى تحدده.rar

ممكن يكون ذلك من خلال معادلة صفيف (Ctrl+Shift+Enter) =SUM(IF($B$2:$B$5=$F$2,$C$2:$D$5,"")) او هذه معادلة عادية =SUMPRODUCT(--($B$2:$B$5=$F$2)*$C$2:$D$5)

جرب اجمع الاتنين =SUMIF(B:B;F2;C:C)+SUMIF(B:B;F2;D:D)

مشكور استاذنا الكريم ا محمد طاهر ولاثراء الموضوع بالكود والغاء علامة $ وتحويل القيم الى رقمية لاجراء العمليات الحسابية على المخرجات بكل سهولة Sub splitText() Dim splitVals As Variant Dim totalVals As Long For Each xx In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row) splitVals = Split(xx.Value, "$") totalVals = UBound(splitVals) Range(Cells(xx.Row, xx.Column + 1), Cells(xx.Row, xx.Column + 1 + totalVals)).Value = splitVals Next FIND ConvertTextNumberToNumber End Sub Sub ConvertTextNumberToNumber() On Error Resume Next For Each Y In Sheet1.UsedRange.SpecialCells(xlCellTypeConstants) If IsNumeric(Y) Then Y.Value = Val(Y.Value) Next End Sub Sub FIND() Range("D:D").Replace What:="–", Replacement:="", LookAt:=xlPart End Sub تقبل تحياتي Split PT Prices around the world.rar

السلام عليكم ورحمة الله وبركاته اليكم الملف بعد تعديل بسيط عليه فى تقرير كشف حساب تحليلى . وارجو العمل على اصدار 2010 لتفادى قصور الاصدارات السابقه لحين اصدار ملف جديد سيكون ان شاء الله بصيغة 2003 تقبلو خالص تحياتى ملف المقاولات الاصدار الاول تجريبى.rar

السلام عليكم بار بسيط لمعاينة حركة اي كود على الفورم يمكنك استخدامة لاي كود يستخدم فور نكست على الفورم ويمكنك نقله مع الاكواد الخاص به الى اي فورم في ملفك هذا كود البار Private Sub kh_Update_Par(MI As Long, MX As Long) Static N As Integer If N = 0 Then Me.MousePointer = 11 Me.LabelPar.Visible = True Me.LabelPar.Caption = "" N = Int(MX / 30) End If '---------------------------------- If N Then If MI Mod N = 0 Then Me.LabelPar.Caption = Me.LabelPar.Caption & "n" '---------------------------------- If MI = MX Then N = 0 Me.LabelPar.Visible = False Me.MousePointer = 0 End If End Sub وهذه السطرين تضعها نهاية السلسلة فور نكست في اي كود تريد تشغيل البار معه مع تغيير المتغييرات الخاصة بالكود حسب الكود خاصتك Call kh_Update_Par(i, Lr) DoEvents وهذا الكود يمنعك من غلق الفورم اثناء حركة البار Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If Me.MousePointer = 11 Then Cancel = 1 End Su واذا كنت تستخدم هذا الكود في الفورم خاصتك استخدم السطر التالي في بداية الكود خاصتك If Me.MousePointer = 11 Then Cancel = 1: Exit Sub تحياتي المرفق 2003 بار تحديث البيانات.rar

السلام عليكم نعم كلامك صحيح يحتاج تكرار الامر على نطاق واسع برضه ابعدت الالوان لانها تتراكب فوق بعضها Option Explicit '''النطاق الذي تريد فحصه Const rAddres As String = "B4:B12" '''' خلية رقم الفحص Const vAddres As String = "F3" Sub kh_Test() Dim r%, rr% With Range(rAddres) .Cells(0, 2).Resize(1, 2).Value = Array("Addres", "Sum") With .Cells(1, 2).Resize(1, 2) Range(.Cells, .Cells.End(xlDown)).ClearContents End With For rr = 1 To .Rows.Count For r = rr To .Rows.Count SumTest .Cells, Range(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) SumTest .Cells, Union(.Cells(rr, 1), .Cells(r, 1)), Val(Range(vAddres)) Next Next End With End Sub Sub SumTest(MyRng As Range, TestCol As Range, MyVal As Double) Dim iCol As Range, Adr$ With MyRng For Each iCol In .Cells If WorksheetFunction.Sum(Union(iCol, TestCol)) = MyVal Then Adr = Union(iCol, TestCol).Address With Cells(Rows.Count, .Column + 1).End(xlUp).Offset(1, 0) If WorksheetFunction.CountIf(Columns(.Column), Adr) = 0 Then .Cells(1, 1).Formula = Adr .Cells(1, 2).Formula = "=SUM(" & Adr & ")" End If End With End If Next End With End Sub شاهد المرفق للتجربة 2003 سيناريو التجميع 2.rar

السلام عليكم احبتي في الله انا نفسي نفذت مني الكلمات لم تبقى معي الا قطرات دمعي جزاكم الله خيرا هذا مرفق امثلة لما ذكر امثلة.rar

هذا هو الكود Sub OFFICNA() Dim LR As Long, LR2 As Long, ws As Worksheet, ws2 As Worksheet Set ws = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") LR = ws.Range("a" & Rows.Count).End(xlUp).Row LR2 = ws2.Range("a" & Rows.Count).End(xlUp).Row If ws.Range("a2").Value = "" Then MsgBox ("لا توجد بيانات لترحيلها") Else ws.Range("a2:b" & LR).Copy ws2.Range("a" & LR2 + 1) ws2.Select End If End Sub هذا الجزء لتعريف أوراق العمل وتعريفها برمز إختصار اخترت ان يكون ws و ws2 Set ws = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") هذا لتحديد أخر صف فيه بيانات في ورقة العمل المعرفة اختصاراً ws والتي هي Sheet1 LR = ws.Range("a" & Rows.Count).End(xlUp).Row هذا لتحديد أخر صف فيه بيانات في ورقة العمل المعرفة اختصاراً ws2 والتي هي Sheet2 LR2 = ws2.Range("a" & Rows.Count).End(xlUp).Row هذا شرط عدم الترحيل اذا كانت الخلية A2 فاضية وتظهر رسالة تنبيه بعدم التنبيه If ws.Range("a2").Value = "" Then MsgBox ("لا توجد بيانات لترحيلها") في حال عدم تحقق شرط خلو الخلية A2 من البيانات يتم تنفيذ هذا الجزء وهو الخاص بعملية نسخ المدى A2: B مرتبطة بأخر صف فيه بيانات LR ويتم لصقها في ورقة البيانات المسمية WS2 في المدى A وأول صف فارغ في الورقة المرحل اليها ws2 ws.Range("a2:b" & LR).Copy ws2.Range("a" & LR2 + 1) هذا الجزء لاختيار ورقة العمل ws2 بعد الانتهاء من الترحيل ws2.Select ان شاء الله اكون وفقت في الشرح أما بالنسبة لطلبك فهو غير واضح؟؟

يمكن عمل ذلك باختيار الشيت ثم طباعته و يكون الاختيار باسم الشيت كما فى الكود الاول أو رقمه كما فى الكود الثاني و هما لطباعة الثلاث شيتات فى الملف أما الكود الاخير فهو لطباعة جميع أوراق العمل مع ملاحظة أن يكون فى الورقة أي بيان قابل للطباعة ( ليست خالية ) Sub Print3Sheets() ActiveWorkbook.Worksheets("sheet1").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets("sheet2").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets("sheet3").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub Sub Print3Sheets2() ActiveWorkbook.Worksheets(1).Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets(2).Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWorkbook.Worksheets(3).Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub Sub PrintAllsheets() For i = 1 To ActiveWorkbook.Worksheets.Count ActiveWorkbook.Worksheets(i).Activate ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Next End Sub PrintSheets2.rar