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

ما شاء الله افكار رائعة من الجميع وهذه محاولتي المتواضعة يمكن كتابة هذه المعادلة في الخلية D3 وسحب المعادلة يسارا ثم اسفل لتطبق على الجميع =IF($B3>SUM($D$2:D$2),D$2,$B3-SUM($C3:C3)) بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته ما عليك سوى تحديد الشيتات المرغوب دمجها كما في الصورة Sub Merge_worksheets() Dim Rng, C, A(), P&, i&, F&, Y&, N&, derligne&, lastrow& Dim DestArr() As String Dim ws As Worksheet: Set ws = Sheets("تجميع") lastrow = ws.Cells(Rows.Count, "a").End(xlUp).Row + 1 N = ws.Range("W" & Rows.Count).End(xlUp).Row Set Rng = ws.Range("W2:W" & N) Application.ScreenUpdating = False If ws.[V2] = Empty Then m = MsgBox("المرجوا تحديث قائمة أسماء الشيتات", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "انتباه"): Exit Sub On Error Resume Next For Each C In Rng If C Then If C <> "" Then ReDim Preserve DestArr(0 To P) DestArr(P) = C.Offset(, -1).Value P = P + 1 End If End If Next For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) For i = 1 To UBound(Rng, 1) ws.Range("A2:N" & lastrow).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Rng, 2), 1 To Y) For F = 1 To UBound(Rng, 2) A(F, Y) = Rng(i, F) Next Next With ws ws.Range("a2").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next On Error GoTo 0 ws.Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub ListSheets() Dim derligne&, x As Integer Dim ws As Worksheet: Set ws = Sheets("تجميع") derligne = ws.Cells(Rows.Count, 22).End(xlUp).Row + 1 Application.ScreenUpdating = False ws.Range("v2:v" & derligne).ClearContents x = 2 For Each WSdata In Worksheets If WSdata.Name <> ws.Name Then ws.Cells(x, 22) = WSdata.Name x = x + 1 End If Next End Sub تجميع V2.xlsm

السلام عليكم اخى الكريم بن علية حاجى .. دمت لنا تزدنا من علمك وكرمك اخى الفاضل ابو احمد اشكرك على الاضافة الرائعة واسمحوا لى ان اثرى الموضوع ببعض ماتعلمته منكم 1تقسم قيمه الدين.xlsx

إذا أنت تريد تاريخ أكبر بعد تاريخ آخر دفعة اكتب الدالة التالية =MAXIFS(الجدول2[موعد القسط التالى];الجدول2[الاسم];الجدول2[@الاسم])+5 بحيث الرقم 5 يمثل عدد الأيام المطلوبة بعد تاريخ آخر قسط

القاعدة الخلفية (الجداول) : لا يهم اي نسخة من الاوفيس/الاكسس تم تنصيبها ، فالملف الذي به الجداول يعمل على النواتين ، ويجب ان يكون بصيغة accdb او mdb (طبعا تستطيع تغيير الصيغة لاحقا للتمويه ، الى bak مثلا) ، القاعدة الامامية (نماذج) : بما ان برنامجك يعمل على النواتين الآن ، فإذا تركته بصيغة accdb ، فانه سيعمل على جميع نسخ الاكسس (2007 او اكبر) ، وسواء نواة 32بت او 64بت ، اما اذا اردت ان تقفل البرنامج وتحوله الى صيغة accde : - يجب ان تستعمل حاسبة منصّب عليها اوفيس/اكسس 32بت ، ومنها تعمل نسخة مقفولة بصيغة accde ، وهذه النسخة يمكنك استخدامها فقط على الحواسيب التي عليها اوفيس/اكسس 32بت ، - يجب ان تستعمل حاسبة منصّب عليها اوفيس/اكسس 64بت ، ومنها تعمل نسخة مقفولة بصيغة accde ، وهذه النسخة يمكنك استخدامها فقط على الحواسيب التي عليها اوفيس/اكسس 64بت. وبغض النظر ، سواء عندك نسخة accde لنواة 32بت او 64بت ، فالنسختين تعملان مع الجداول ، ويمكنك ربط نسخة النواة 32بت وربطها مع الجداول ، وعلى حاسبات اخرى عليها نسخة نواة 64بت وكذلك ربطها بالجداول ، داخل نفس الشبكة.

صراحة لم افهم مادا تقصد يمكنك ارفاق عينة للنتيجة المطلوبة ادا امكن . اظافة لا يوجد اي جدول باسم معرف على الملف اما ادا كنت تقصد ترتيبها بنفس التسلسل الموجود على كل ملف تم تغييره بتسلسل جديد ليتوافق مع شكل الملف لديك في اول مشاركة على العموم ادا كان هدا هو طلبك اجعل الكود بهده الطريقة Sub importer() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("الجميع") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name Then For i = 5 To Sheets(sh).Range("a" & Rows.Count).End(xlUp).Row + 1 If .Range("a5") = "" Then lig = 5 Else lig = .Range("a" & Rows.Count).End(xlUp).Row + 1 For j = 1 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) Next Next End If Next End With End Sub واي اضافة او تعديل لا تتردد في دكره سوف نكون سعداء لمساعدتك بالتوفيق..

يمكن أيضا التجميع عن طريق أداة برو كويري Power Query المتوفرة بالأكسل والتحديث عن طريق بيانات ملاحظة تم تحويل البيانات إلى جداول لتسهيل العمل تجميع التلاميذ.xlsx

لوسمحت ترفع الملف على احد مواقع الرفع ، ثم ترفق لنا الرابط هنا

وعليكم السلام ورحمة الله وبركاته استخدم هذه المعادلة =EDATE(J14;-2)

وهذه الدالة بعد تقليل أسطرها وتبديل التكرار باستخدام دالة replace Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String sText = Nz(sText, "") sWord = Nz(sWord, "") lStr = "<font color=red>" rStr = "</font>" sText = Replace(Replace(sText, lStr, "", 1), rStr, "") sText = Replace(sText, sWord, lStr & sWord & rStr, 1) sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) RichText = sText End Function

عزيزي أحيانا اللي جالسين في المدرجات يرون ما لا يراه اللاعبون. وأكيد مرت عليك أن تقوم بتعديل أكوادك أكثر من مرة وأحيانا تضحك من عملك وتتساءل كيف غفلت وارتكبت تلك الهفوات. على كل أرجو الانتباه أن أستخدم الدالة للاستعلام ولحقل مذكرة وهنا ستغير من رأيك السابق مع مزيد من التأمل. وهنا الكود الطويل القصير مع شرح مبسط لغير الخبراء: Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String Dim sPos As Integer 'للتخلص من القيمة null sText = Nz(sText, "") sWord = Nz(sWord, "") 'لتكرار استخدام عبارتي حصر اللون وضعناهما في متغيرين lStr = "<font color=red>" rStr = "</font>" 'لإزالة التنسيق القديم من حقل المذكرة sText = Replace(sText, lStr, "", 1) sText = Replace(sText, rStr, "", 1) 'تكرار لتلوين جمعيع الكلمات في الحقل الواحد sPos = InStr(1, sText, sWord) Do While sPos > 0 sText = Left(sText, sPos - 1) & _ lStr & sWord & rStr & _ Mid(sText, sPos + Len(sWord)) sPos = InStr(sPos + Len(sWord & lStr), sText, sWord) Loop 'لاحتصار النص وخصوصا لحقل المذكرة بإزالة تكرار عبارات الحصر للون sText = Replace(sText, rStr & " " & lStr, " ", 1) sText = Replace(sText, rStr & "" & lStr, "", 1) RichText = sText End Function أما بالنسبة للاختصار فيمكن التالي: من سطرين إلى سطر لأزالة التنسيق القديم وهذ مطلوب لحقل مذكرة وغير مطلوب للاستعلام. ما تفضلت به بتبديل التكرار بدالة replace وسأقوم بتجربتها مع أني استخدمت وظيفتها بدلا منها واستخدمتها في الدالة 4 مرات. من سطرين إلى سطر لإزالة تكرار عبارات حصر اللون وهو مهم أكثر في حقل المذكرة لأننا نقوم بتخزين النص والتنسيق معا.

الصورة تظهر في المعاينة طبيعية ويمكن طباعتها ألوان بحذف علامة الصح في الأمر black and white في إعدادات الصفحة آخر تبويب بالتوفيق

الأفكار تتدافع للاستفادة من الفكرة الجديدة، الآن الدلة تلون أكثر من كلمة في الحقل الواحد. الفكرة التالية هي زيادة خصائص الكلمة كنوع الخط ولون الخلفية وحجم الخط والخط المائل وخط أسفل الكلمة. ما أريده هو تمرير الأداة للدالة عند استخدام الاستعلام. هل أحد جرب هذه الحيثية؟ Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String Dim sPos As Integer sText = Nz(sText, "") sWord = Nz(sWord, "") lStr = "<font color=red>" rStr = "</font>" sText = Replace(sText, lStr, "", 1) sText = Replace(sText, rStr, "", 1) sPos = InStr(1, sText, sWord) Do While sPos > 0 sText = Left(sText, sPos - 1) & _ lStr & sWord & rStr & _ Mid(sText, sPos + Len(sWord)) sPos = InStr(sPos + Len(sWord & lStr), sText, sWord) Loop sText = Replace(sText, rStr & " " & lStr, " ", 1) sText = Replace(sText, rStr & "" & lStr, "", 1) RichText = sText End Function SearchSel_04.accdb

لم يأني في خلدي فكرة عمل الصندوق مع الاستعلام. فكرة جميلة جدا، مثال تعلمت منه الجديد المفيد اليوم. المثال بعد تطبيق الفكرة الجديدة. SearchSel_03.accdb

السلام عليكم 🙂 لوسمحت ترفق اكبر ملف عندك ، لازم نجرب عليه 🙂 جعفر

هناك طريقة أخرى؛ وهي أن نجعل الصفوف المطابقة للبحث تظهر ملونة في الأعلى، وغير المطابقة تظهر غير ملونة في الأسفل.. أرجو أن تكون هذه الفكرة مرضية لك.. SearchIn HTML Table.accdb

وعليكم السلام 🙂 اعمل جدول خاص لهذا ، وتحتاج عمودين على الاقل: نوع_التوصيل ، اسم_الشركة_المخزن مثلا: شركة ، شركة 1 شركة ، شركة محمد شركة ، شركة المواد الغذائية توصيل ، مخزن 1 توصيل ، مخزن 2 توصيل ، مخزن 3 توصيل ، مخزن 4 جعفر

السلام عليكم 🙂 تقريبا جميع الوحدات النمطية خضعت للتغيير 🙂 رجاء تجربة جميع الازار 🙂 1566.اخفاء واظهار كائنات الاكسس.accdb.zip

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الكريم ورقة القائمة الخلية(D2) =IFERROR(IF('النسب '!D3<>"";INDEX('النسب '!$D$3:$D$500;MATCH(0;COUNTIF($D$1:D1;'النسب '!$D$3:$D$500);0));"");"") ورقة الشغل القائمة المنسدلة لاسم العملية (G5) الخلية =OFFSET(القائمة!$D$2;0;0;COUNTA(القائمة!D:D)-1) القائمة المنسدلة للنسبة (H5) الخلية =OFFSET('النسب '!$F$3;0;0;COUNTA('النسب '!F:F)-1) (I5) الخلية =IF(H5<>"";INDEX('النسب '!$E$3:$E$500;MATCH(1;INDEX((الشغل!H5='النسب '!$F$3:$F$500)*(الشغل!G5='النسب '!$D$3:$D$500);0;1);0));"") بالتوفيق...... الصوب نسب2023 -V1.xlsm

الحاسبة التي تم تنصيب اكسس 32بت عليها ، استعمل قاعدة بياناتك التي قفلتها بنواة 32بت ، والحاسبة التي تم تنصيب اكسس 64بت عليها ، استعمل قاعدة بياناتك التي قفلتها بنواة 64بت. لا يمكنك الخلط بينهم

يجب ان تكون عندك نسختين ، واحدة لنواة 32بت ، واخرى لنواة 64بت 🙂