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

حسب فهمي للمطلوب رغم عدم دقة هذه الطريقة في حساب الفرق بين تاريخين لأنها لا تراعي الشهور ذات الأيام 31 أو 28 أو 29 على العموم يمكنك استعمال هذه المعادلة في G4 للحصول على عدد الأيام =IF(DAY(E4)<DAY(D4),30,0)+DAY(E4)-DAY(D4) وهذه في F4 للحصول على عدد الشهور =IF((IF(DAY(E4)<DAY(D4),-1,0)+MONTH(E4))<MONTH(D4),12,0)+IF(DAY(E4)<DAY(D4),-1,0)+MONTH(E4)-MONTH(D4) وهذه للحصول على عدد السنوات =IF((MONTH(E4)-MONTH(D4))<(IF((IF(DAY(E4)<DAY(D4),-1,0)+MONTH(E4))<MONTH(D4),12,0)+IF(DAY(E4)<DAY(D4),-1,0)+MONTH(E4)-MONTH(D4)),-1,0)+YEAR(E4)-YEAR(D4) طبعا يرجع طول المعادلة إلى عدم اعتمادها على نتائج الأعمدة الأخرى (اليوم والشهر) بالتوفيق

محاولتي: Periods_01.xlsx

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

وعليكم السلام ورحمة الله جرب الكود التالى Dim ws As Worksheet: Set ws = Sheets(1) Dim sh As Worksheet: Set sh = Sheets(2) sh.Range("A5:N1000") = "" k = 5 lr = ws.Range("A" & Rows.Count).End(xlUp).Row For i = 3 To lr Dim columns(1 To 3) As Variant columns(1) = "J" columns(2) = "L" columns(3) = "N" For c = 1 To 3 Dim column As String column = columns(c) If ws.Range(column & i) >= sh.[D2] And _ ws.Range(column & i) <= sh.[G2] Then For j = 2 To 20 sh.Cells(k, j) = ws.Cells(i, j) Next k = k + 1 End If Next c Next i

ما شاء الله عليكم تعمقتم في الموضوع وخضتم وتشعبتم في بحور المكتبات 😄🖐🏼️ أما أنا أعود بكم للموضوع الأصلي لأنه خطرت لي فكرة فما أردت لها أن تضيع في زحام الأفكار 😁👌🏼 الفكرة سلمكم الله هي أن تتيح للمستخدم كتابة أنواع الملفات في معامل الدالة على شكل مصفوفة هكذا ("jpg", "png", "pdf", "rar") ومن ثم يجمعها الكود بالشكل الصحيح ليتم استخدامها في الكود حسب الصياغة الصحيحة وإضافة النجمة لها * .. هكذا (jpg, *.png, *.pdf, *.rar.*) ولعمل ذلك استعنت ب ChatGPT لكتابة الكود التالي مع الكثير من التعديلات لإيصال الفكرة لكم .. 🙂 Function FilesTypes(ParamArray Types() As Variant) As String Dim combinedTypes As String Dim i As Integer ' Initialize the combined string combinedTypes = "" ' Loop through the array items and concatenate with the delimiter For i = LBound(Types) To UBound(Types) combinedTypes = combinedTypes & "*." & Types(i) & ", " Next i ' Remove the last "," If Len(combinedTypes) > 0 Then combinedTypes = Left(Trim(combinedTypes), Len(Trim(combinedTypes)) - 1) End If FilesTypes = IIf(Len(combinedTypes) > 0, combinedTypes, "*.*") End Function Sub testing() Debug.Print FilesTypes("jpg", "png", "pdf", "rar") 'Result = *.jpg, *.png, *.pdf, *.rar Debug.Print FilesTypes() 'Result = *.* End Sub ملاحظة مهمة : طبعا حسب إفادة موقع مايكروسوفت المعامل من نوع ParamArray يجب أن يكون في آخر المعاملات في الدالة وهو إختياري في جميع الأحوال ويمكن تركه فارغا .. ولا يصلح أن يتم استخدامه مع المعاملات من نوع ByVal, ByRef, or Optional . لذلك تركت لك مسألة التعامل مع المعامل btOptionDialog الذي في كودك الأصلي لتجد له حلا 😅🖐🏼️ مرجع : https://learn.microsoft.com/ar-sa/office/vba/language/reference/user-interface-help/function-statement

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

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

وعليكم السلام واجهة جميلة جدا..عاشت الايادي

وعليكم السلام يمكن استخدام أداة السلينوم والتي يمكن تسطيبها في الإكسيل والتعامل معها برمجياً من خلال VBA .. ويوجد موضوعات قدمتها في أكاديمية الصقر بخصوص هذه الأداة ولكن المنتدى هنا يمنع فيه وضع الروابط الخارجية.

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

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

انظر لما قصدته في مثالك المعدل واجهة جميلة منسدلة2.rar

سلمت يمينك اختصار اكثر من رائع جزاكم الله خير الله يجزيكم الجنة الف الف شكر استاذ احمد على هذه الروائع

شكرا جزيلا أخي @فوزي صلاح اليافعي على الهدية الجميلة 🙂🌹

لا بأس الف سلامة عليك الله يجعل ما اصابك اجر و عافية و طهور انشاء الله اللَّهُمَّ رَبَّ النَّاسِ أَذْهِبْ الْبَاسَ اشْفِ وَأَنْتَ الشَّافِي لَا شِفَاءَ إِلَّا شِفَاؤُكَ شِفَاءً لَا يُغَادِرُ سَقَمًا اللَّهُمَّ رَبَّ النَّاسِ أَذْهِبْ الْبَاسَ اشْفِ وَأَنْتَ الشَّافِي لَا شِفَاءَ إِلَّا شِفَاؤُكَ شِفَاءً لَا يُغَادِرُ سَقَمًا اللَّهُمَّ رَبَّ النَّاسِ أَذْهِبْ الْبَاسَ اشْفِ وَأَنْتَ الشَّافِي لَا شِفَاءَ إِلَّا شِفَاؤُكَ شِفَاءً لَا يُغَادِرُ سَقَمًا

طيب UCanAccess هو تطبيق Java JDBC Driver خالص يسمح لمطوري Java وبرامج عملاء JDBC بقراءة/كتابة ملفات قاعدة بيانات Microsoft Access (.mdb و.accdb). لا حاجة إلى ODBC. Features Supported Access formats: 2000, 2003, 2007, 2010 SELECT, INSERT, UPDATE, DELETE statements. Transactions and savepoints Access data types: YESNO, BYTE, INTEGER, LONG, SINGLE, DOUBLE, NUMERIC, CURRENCY, COUNTER, TEXT, OLE, MEMO, GUID, DATETIME Concurrent access from multiple users (i.e., multiple application server threads) Connection pooling ANSI 92 SQL, core SQL-2008 MS Access SQL Main Access functions implementation You can execute select queries defined and saved in Access Criteria in LIKE clause Access date format (e.g., #11/22/2003 10:42:58 PM#) Both double quote " and single quote ' as SQL string delimeters Command Line Console. You can run SQL commands and display their results. CSV export command أما access runtime لا يمكن تعديل تصميم الجداول والاستعلامات والنماذج والتقارير على جهاز لا يحتوي على Access كاملاً ولكن بوجود access runtime يتم من خلاله تشغيل قاعدة البيانات فقط بدون وضع التصميم access runtime لابد ان يتم تحميله حسب الاصدار الذي تحتاجه تبعا للاصدار الذى تم تصميم قاعدة البيانات عليه والنواة الخاصة بها كذلك يعنى مش أى access runtime ينفع مع كل قواعد البيانات

هل من الممكن تصدير المكتبات المستخدمة في المشروع الى جهاز آخر (أثناء عملية التثبيت مثلاً - على فرض أن المشروع تم تحزيمه بدقة ) حتى لو اختلفت فيه نسخة الأوفيس ؟ كون أن المكتبات هي ملفات معظمها Dll .... الخ من صيغ !!

جزانا الله واياكم خير الجزاء الحمد لله تعالى الذى هدانا وما كنا لنهتدى لولا ان هدانا الله عزوجل ، الحمد لله الذى تتم بنعمته الصالحات

طيب فى موضوع هنا ممكن يكون مفيد و بصراحة مش فاضى اشوف الفيديو الان بس حبيت اضع الرد اثراء للموضوع

جزاك الله كل خير على ما صنعت ، خذ راحتك وان شاء الله في العمر بقية

أبدعت ، و أبدعت ، ثم أبدعت بنجاح تعدى الـ 100%

اتفضل يا افندم قاعدة بياانات الاحتفاظ بتصدير المراجع و المكتبات وكذلك استرجاع المراجع والمكتبات يرجى مراجعتنا بعد التجربة للتأكد ان شاء الله تقريبا بنسبة كبيرة جدا جدا تتعدى الـ 100% سوف تفلح Reference Management.accdb

تمام اخي @عمر الجزاوى ممكن ارفاق ملف بشكل البيانات تحت بعض لاتمكن من تحديد النطاق لان هناك عدة صفوف فارغة بعد الترحيل هل تحتفظ بها ام نقوم بازالتها

أخي الكريم قم باستيراد ملف dmocx.dll من المسار الموضح بالصورة ، وستظهر معك المكتبة ( ctv OLE Control module ) ، وغيرها المسار في Win10 "C:\Windows\System32\dmocx.dll" وبالنسبة للمكتبة Microsoft Forms 2.0 Object Library ، فقم باستيراد الملف ( FM20.dll ) من المسار التالي في Win10 : (C:\Windows\System32\FM20.DLL) وأرفقت ملف تم اضافة المكتبات في الـ VBA Try.accdb

شكرآ لمشرفي ومنتسبي هذا المنتدى الرائع

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

يمكن تنفيذ ماكرو بمجرد انتقال المؤشر من خلية إلى أخرى في ورقة Excel باستخدام حدث تغيير الخلية (Worksheet_SelectionChange) والماكرو التالية: 1. افتح ورقة Excel التي ترغب في تنفيذ الماكرو فيها. 2. انقر بزر الماوس الأيمن على علامة التبويب للورقة التي ترغب في تنفيذ الماكرو فيها وحدد "عرض الشفرة" (View Code). 3. ستظهر نافذة "Microsoft Visual Basic for Applications" مع وحدة كائن الورقة المحددة. 4. في الجزء العلوي من النافذة، انقر فوق قائمة القوالب المنسدلة وحدد "Worksheet" ثم اختر "SelectionChange". 5. ستظهر دالة جديدة في وحدة الورقة المحددة. 6. ضمن الدالة، قم بكتابة رمز الماكرو الذي ترغب في تنفيذه عند تغيير تحديد الخلية. مثال: Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' قم بكتابة رمز الماكرو الذي ترغب في تنفيذه هنا ' مثال: MsgBox "تم تحديد خلية جديدة" End Sub 7. بعد كتابة رمز الماكرو، احفظ التغييرات وأغلق نافذة "Microsoft Visual Basic for Applications". 8. عند الآن، سيتم تنفيذ الماكرو عند تغيير تحديد الخلية في الورقة المحددة.

مرفق المثال مرة أخرى كمرجع لحالات مستقبلية مشابهة لمن يحتاجها Periods_02.xlsx

الحمد لله على سلامتك اخونا وحبيبنا واستاذنا خليفة .. سلامة دائمة ان شاء الله وعودا حميدا ..

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

نعم المكتبات المرهونة بإصدار الاوفيس عند اضافتها على اصدار اوفيس ومع فتح القاعدة باصدار أعلى من اللإصدار الذى تم التصميم واضافة المكتبات يتم تحديث خذخ المكتبات تبعا للاصدار الجديد والأحدث طيب أين المشكلة عند فتح نفس القاعدة بإصدار اوفيس أقل فى الاصدار من أخر اصدار أوفيس تم فتح القاعدة به المكتبات يمكن أن يحدث لها Upgrade ولكن ابدا لن يحدث لها downgrade للتبسيط اكثر تم اصدار قاعدة بيانات اكسس 2000 عند محاولة فتح القاعدة على اكسس 2003 تعمل بنجاح ولو تم فتح نفس القاعدة على اكسس 2007 تعمل ايضا بنجاح ولكن عند محاولة فتح نفس القاعدة على اكسس 2000 أو اكسس 2003 لن تعمل وستتوقف المكتبة عن العمل وسوف تحصل على Missing References لاى نوع من المكتبات التى تعتمد على اصدار الاوفيس طبعا هذه تمثل مشكلة كبيرة جدا فى استخدام القاعدة على شبكة محلية عند اختلاف نسخ الاوفيس طبعا وللاهمية هذا كما اشرت مسبقا للمكتبات المرهونة برقم اصدار الاوفيس الربط المسبق Early Binding: 1. ان تختار مكتبة الاكسل (طبعا لهذا المثال) ، 2. ثم الكود يكون شيء من هذا القبيل: Dim oExcel As Excel.Application Set oExcel = CreateObject("Excel.Application") oExcel.Visible = True والمشكلة هنا ، انه اذا اخترت مكتبة اكسل الاقل (مثلا اكسل 😎 ، فأي كمبيوتر يحتوي على اكسل 8 او اكبر (9 ..12..15) فالمكتبة/البرنامج سوف يشتغل بطريقة صحيحه ، بينما اذا كان عندك اكسل 6 ، فستحصل على خطأ ، ولن يعمل الكود الميزة في هذه الطريقة انها اسرع في العمل ، والاهم من هذا ، انها تساعدك في اعطائك الاوامر (مثلا تكتب امر معين ثم تكتب نقطة . فتظهر لك الاوامر التي تستطيع استعمالها). اما اذا استعملنا الربط المتأخر Late Binding فإننا لا نحتاج الى اختيار مكتبة الاكسل ، ونكتب الكود اعلاه هكذا ، والذي يشتغل على جميع اصدارات الاكسل: Dim oExcel As Object Set oExcel = CreateObject("Excel.Application") oExcel.Visible = True المشكلة هنا ، اننا يجب ان نعتمد على انفسنا لعمل الكود ، فالاكسس لن يساعدنا ، وهو ابطأ نوعا ما ونسبيا من الطريقة الاولى

الحمد لله على السلامة استاذ خليفة

شاهد هذا الموضوع:

ومداخلة سريعة اعذرني فيها بحثاً عن معلومة أوثق من تلك التي لدي. لو انا صممت فكرتي ( الملف اللي انا ارفقته حصراً ) على آكسيس ٢٠١٠ ، وفتحت الملف على جهاز تاني عليه إصدار ٢٠١٦ مثلاً ، فهل ستعمل أم لا ؟ علّي استفيد من هذا التوضيح 😊 ؛

نفس اليوزرفورم ونفس الطلب

وعليكم السلام ورحمة الله تعالى وبركاته هناك حل اخر ممكن ايضا جعل الكود بهده الطريقة Sub Filter_Class2() Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD") Dim D1 As Object, D2 As Object, D3 As Object Dim i%, a As Boolean, b As Boolean, c As Boolean Dim x%, Y%, m%, z%, Réf, ky, Rng$ Set D1 = CreateObject("Scripting.Dictionary"): Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") With WSdest Application.ScreenUpdating = False WSdest.Range("M4:V32,X4:AG32,AI4:AR32").ClearContents i = 7 Do While i <= .Rows.Count If WSdest.Cells(i, 2) <> "" And WSdest.Cells(i, 2) <> HasFormula Then Rng = Mid(Trim(WSdest.Cells(i, 2)), 1, 1) Select Case Rng Case "3": a = True: b = False: c = False Case "2": b = True: a = False: c = False Case Else: b = False: a = False: c = True End Select Réf = Application.Transpose(.Cells(i, 2).Resize(, 13)) Réf = Application.Transpose(Réf) If a Then D3(z) = Join(Réf, "*"): z = z + 1 ElseIf b Then D2(Y) = Join(Réf, "*"): Y = Y + 1 Else D1(x) = Join(Réf, "*"): x = x + 1 End If i = i + 1 Else Exit Do End If Loop m = 4 If D3.Count Then For Each ky In D3 WSdest.Cells(m, "M").Resize(, 13) = Split(D3(ky), "*") m = m + 1 Next ky End If m = 4 If D2.Count Then For Each ky In D2 WSdest.Cells(m, "X").Resize(, 13) = Split(D2(ky), "*") m = m + 1 Next ky End If m = 4 If D1.Count Then For Each ky In D1 WSdest.Cells(m, "AI").Resize(, 13) = Split(D1(ky), "*") m = m + 1 Next ky End If WSdest.Range("M4").CurrentRegion.Value = WSdest.Range("M4").CurrentRegion.Value WSdest.Range("X4").CurrentRegion.Value = WSdest.Range("X4").CurrentRegion.Value WSdest.Range("AI4").CurrentRegion.Value = WSdest.Range("AI4").CurrentRegion.Value End With End Sub تقرير المصلحة.xlsm

جزاك الله خير الجزاء وربنا يبارك ف يعلمك واهلك ومالك

تفضل أخي حسب مافهمت تقرير للكل وتفرير للرقم المختار ووافني بالرد test-1.rar

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

وعليكم السلام ورحمة الله وبركاته ضف هذا السطر قبل الخطأ مباشرة On Error Resume Next st = Mid(Trim(.Cells(i, 2)), 1, 1)

تفضل اخي سعد محمد_2.xlsm

اخي ربما ليس هناك مستحيل لاكن يتعين عليك شرح المطلوب بطريقة اوضح تقضل لقد حاولت الاشتغال على ملفك بطريقة متقدمة نوعا ما ربما تفيدك واستخراج النتائج على التيكست بوكس لكل نوع من الحركة بالاعتماد على ما فهت منك وهو عملية الجمع والطرح تكون بالشكل التالي Purchases + Sales returns - sales - Purchases returns واي استفسار او اظافة لا تتردد في دكره سوف تكون سعداء بحصولك على النتيجة المتوقعة Dim AllData(), the_range, wsdata, Target_columns(), Dates(), wsdata2, réf() Function MergeArray2DVert(A, B) maxtab1 = UBound(A) Dim tbl(): ReDim tbl(1 To UBound(A) + UBound(B), 1 To UBound(A, 2)) For I = LBound(A) To UBound(A) For C = 1 To UBound(A, 2): tbl(I, C) = A(I, C): Next Next I For I = 1 To UBound(B) For C = 1 To UBound(B, 2): tbl(maxtab1 + I, C) = B(I, C): Next Next I MergeArray2DVert = tbl End Function Private Sub UserForm_Initialize() 'دمج بيانات الجداول Dim Tablo1, Rng_1, rng2, T Tablo1 = [Tableau1]: Rng_1 = [Rng_2]: rng2 = [Rng_3]: rng3 = [Rng_4] AllData = MergeArray2DVert(Tablo1, Rng_1) AllData = MergeArray2DVert(AllData, rng2) AllData = MergeArray2DVert(AllData, rng3) the_range = "Tableau1" ' For i = 1 To UBound(AllData): AllData(i, 3) = CDate(AllData(i, 3)): Next i Me.ListBox1.ColumnCount = 8 wsdata = 8 'Target_columns = Array(1, 2, 3, 4, 6, 7, 8, 11) '(Total)في انتظار توضيح فكرة عمود Target_columns = Array(1, 2, 3, 4, 6, 7, 8) ' عمود التاريخ For I = LBound(AllData) To UBound(AllData): AllData(I, 3) = Format(AllData(I, 3), "dd/mm/yyyy"): Next I 'عمود الكمية For I = LBound(AllData) To UBound(AllData): AllData(I, 8) = Format(AllData(I, 8), "0"): Next I ' عمود Total 'For I = LBound(AllData) To UBound(AllData): AllData(I, 9) = Format(AllData(I, 9), "0.0"): Next I 'Combobox Product name Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 7)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox1.List = réf 'Combobox Invoice type Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 2)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox5.List = réf 'Combobox customer Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 4)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox4.List = réf 'combobox التاريخ Set D = CreateObject("scripting.dictionary") ligneData = 3 For I = LBound(AllData) To UBound(AllData) D(AllData(I, ligneData)) = "" Next I Dates = D.keys filtration Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) ComboBox1.Value = "*": ComboBox4.Value = "*": ComboBox5.Value = "*" Titles ShowAllData On Error Resume Next Me.ListBox1.ColumnWidths = "60;70;80;80;30;190;70;0" On Error GoTo 0 b_tout_Click End Sub '******************************************** Sub ShowAllData() Dim tbl() Dim F As Worksheet, B As Worksheet, S As Worksheet, D As Worksheet Set F = Sheet4: Set B = Sheet2: Set S = Sheet6: Set D = Sheet5 j = Me.ComboBox1: If j = "" Then j = "*" A = Me.ComboBox4: If A = "" Then A = "*" r = Me.ComboBox5: If r = "" Then r = "*" début = Me.ComboBox2 fin = Me.ComboBox3 ligneData = 3 ' عمود التاريخ n = 0 For I = LBound(AllData) To UBound(AllData) If AllData(I, ligneData) >= début And AllData(I, ligneData) <= fin And AllData(I, 7) Like j And AllData(I, 4) Like A And AllData(I, 2) Like r Then n = n + 1: ReDim Preserve tbl(1 To wsdata, 1 To n) C = 0 On Error Resume Next For Each k In Target_columns C = C + 1: tbl(C, n) = AllData(I, k) Next End If Next I If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear End If col = ListBox1.ListCount Call MH Me.Total.Value = Format(Sheet4.[Q1].Value, "0.00") TOTAL_all.Caption = "Total Quantity" & " = " & Format(Sheet4.Range("Q2").Value, "0.000") F.[O1] = "*": B.[O1] = "*": S.[O1] = "*": D.[O1] = "*" End Sub '******************************** Sub MH() Dim A As Worksheet, B As Worksheet, C As Worksheet, D As Worksheet, ws As Worksheet Dim Rng As Range For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case "Purchases", "sales", "Sales returns", "Purchase returns" Set Rng = ws.Range("O1") Rng.ClearContents Set A = Sheet4: Set B = Sheet2: Set C = Sheet6: Set D = Sheet5 If Me.ComboBox5.Value = "Purchases" And Me.ComboBox1.Value <> "*" Then A.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value 'Else A.Range("O1").Value = Empty If Me.ComboBox5.Value = "sales" And Me.ComboBox1.Value <> "*" Then B.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value ' Else B.Range("O1").Value = Empty If Me.ComboBox5.Value = "Sales returns" And Me.ComboBox1.Value <> "*" Then C.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value ' Else C.Range("O1").Value = Empty If Me.ComboBox5.Value = "Purchase returns" And Me.ComboBox1.Value <> "*" Then D.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value 'Else D.Range("O1").Value = Empty Me.Purchases.Value = Format(A.Range("P1").Value, "0.00") Me.sales.Value = Format(B.Range("P1").Value, "0.00") Me.Sales_returns.Value = Format(C.Range("P1").Value, "0.00") Me.Purchase_returns.Value = Format(D.[P1].Value, "0.00") Me.Total.Value = Format(A.[Q1].Value, "0.00") End Select Next ws End Sub sum-Listbox3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton5_Click() Dim ws As Worksheet: Set ws = Sheets("دراسة فندق") Me.Label171.Caption = Format(ws.[F6].Text, "0,#%") 'Me.Label171.Caption = ws.Range("F6").Text 'دخل الحج Me.Label167.Caption = ws.[G6].Text 'دخل الحج Me.Label163.Caption = ws.[H6].Text 'دخل الحج Me.Label187.Caption = ws.[I6].Text 'دخل الحج Me.Label183.Caption = ws.[J6].Text 'دخل الحج Me.Label179.Caption = ws.[K6].Text 'دخل الحج Me.Label199.Caption = ws.[L6].Text 'دخل الحج Me.Label195.Caption = ws.[M6].Text 'دخل الحج Me.Label191.Caption = ws.[N6].Text 'دخل الحج 'رمضان Me.Label169.Caption = Format(ws.[F7].Text, "0,#%") 'دخل رمضان Me.Label165.Caption = ws.[G7].Text 'دخل رمضان Me.Label161.Caption = ws.[H7].Text 'دخل رمضان Me.Label185.Caption = ws.[I7].Text 'دخل رمضان Me.Label181.Caption = ws.[J7].Text 'دخل رمضان Me.Label177.Caption = ws.[K7].Text 'دخل رمضان Me.Label197.Caption = ws.[L7].Text 'دخل رمضان Me.Label193.Caption = ws.[M7].Text 'دخل رمضان Me.Label189.Caption = ws.[N7].Text 'دخل رمضان 'مواسم رمضان Label170.Caption = Format(ws.[F8].Text, "0,#%") 'دخل مواسم رمضان Label166.Caption = ws.[G8].Text 'دخل مواسم رمضان Label162.Caption = ws.[H8].Text 'دخل مواسم رمضان Label186.Caption = ws.[I8].Text 'دخل مواسم رمضان Label182.Caption = ws.[J8].Text 'دخل مواسم رمضان Label178.Caption = ws.[K8].Text 'دخل مواسم رمضان Label198.Caption = ws.[L8].Text 'دخل مواسم رمضان Label194.Caption = ws.[M8].Text 'دخل مواسم رمضان Label190.Caption = ws.[N8].Text 'دخل مواسم رمضان End Sub برنامج دراسة فندق_2.xlsm

وعليكم السلام ورحمه الله وبركاته اخي @ابوعلي الحبيب الكود الخاص بك في المشاركه الاولي ليس به اي مشكله لكن تأكد ان المسار الذي تحفظ به الصورة موجود وهذا كود اخر بسيط سوف يقوم بإنشاء المسار ان لم يكن موجود ويحفظ الصورة Option Explicit Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean Sub Export_Range_As_Picture() Dim Ws As Worksheet, StrToFolder2 As String Dim oRng As Range, sPath As String, oChart As ChartObject Set Ws = ActiveSheet Application.ScreenUpdating = False StrToFolder2 = "D:\pic\" MakeSureDirectoryPathExists StrToFolder2 sPath = StrToFolder2 & Ws.Range("a1").Value & "." & "jpg" Set oRng = Ws.Range("A3:H17") oRng.CopyPicture xlScreen, xlPicture Set oChart = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1) With oChart .Activate .Chart.Paste .Chart.Export Filename:=sPath .Delete End With Application.ScreenUpdating = True End Sub

تفضل استاذ Moosak شوف بنفسك عمل هذه الأداة

فى الvba code editor من tools ثم references ثم الاتى:

عليك السلام ورحمة الله وبركاته جرب هذا فرز محدد.xlsb

لا مستحيل عند الاكسل الكود بعد تعديله ليعطي ارتباط تشعبي Option Explicit Sub Give_Data() If ActiveSheet.Name <> "DATA" Then Exit Sub Dim My_Sh As Worksheet Dim Rg_to_Copy As Range Dim cell_to_Copy As Range Dim m%: m = 5 Dim t%, x% Dim start_date As Date: start_date = Sheets("DATA").[c1] Dim final_date As Date: final_date = Sheets("DATA").[c2] With Sheets("DATA") .Range("a5:y" & Rows.Count).ClearContents .Range("a5:y" & Rows.Count).Interior.ColorIndex = 2 For Each My_Sh In Worksheets If My_Sh.Name = "DATA" Or My_Sh.Name = "ملاحظات" Then GoTo 1 Set Rg_to_Copy = My_Sh.Range("a6").CurrentRegion.Offset(1).Columns(1).Cells For Each cell_to_Copy In Rg_to_Copy cell_to_Copy.Resize(, 24).Interior.ColorIndex = 2 If cell_to_Copy.Offset(, 16) >= start_date _ And cell_to_Copy.Offset(, 16) <= final_date Then .Range("a" & m).Resize(, 24).Value = _ cell_to_Copy.Resize(, 24).Value cell_to_Copy.Resize(, 24).Interior.ColorIndex = 6 m = m + 1 t = t + 1 End If Next '======================= If t <> 0 Then x = .Cells(Rows.Count, 1).End(3).Row .Cells(x + 1, 6) = "حصيلة الورقة :" & My_Sh.Name .Cells(x + 1, 1).Resize(, 24).Interior.ColorIndex = 6 '=================== .Cells(x + 1, 10).Hyperlinks.Add Anchor:=.Cells(x + 1, 10), Address:="", _ SubAddress:=My_Sh.Name & "!A1", TextToDisplay:="Go To: " & My_Sh.Name .Cells(x + 1, 10).Font.Size = 16 '=================== m = x + 3 Else End If t = 0 '================= 1: Next End With End Sub الملف جاهز New_جلب حسب التاريخ.xlsm

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