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

السلام عليكم ورحمة الله كل عام وانتم بخير بمناسبة شهر رمضان المبارك اعاده الله عليكم بالخير ونسال الله ان يتقابل صيامنا وقيامنا وصالح اعمالنا وان ينولنا ثوب ليلة القدر وان يعيننا علي الصيام ورمضان كريم

لعله يفيد مادة الحاسب الآلي القاضي.rar

جرب هذا الملف ولا تنس (اغجبني) تم جماية المغادلات لعدم العبث بها عن طريق الخطأ وصل salim.rar

كل عام وانتم بخير رمضان كريم البحث عن الصور ( موظفين , منتجات ........الخ ) باستخدام الدالة index & match ارجو ان يفيدكم جميع ولاتنسونا بصالح دعاؤكم lookup pic.rar

اخى العزيز / جلال محمد السلام عليكم ورمضان كريم بارفاقك الملف القديم بعد اضافة التعديل الذى قمت انا به على اساس الملف المقتص منه كان لا يظهر المواد ما بعد المجموع الكلى . وبارفاقك الملف الأصلى فى آخر مشاركة فانه يظهر مابعد المجموع الكلى لتغيير النطاق به Set MyRng_All = Range("p13:by2000") ' äØÇÞ ÇáÎáÇíÇ ÇáÐí ÊÑíÏ ÇÖÇÝÉ ÇáÏæÇÆÑ ÝíåÇ '================================================ x = ActiveWindow.Zoom Application.ScreenUpdating = False Range("bz13:ca2000").ClearContents اليس كذلك وعذرا على السؤال ورمضلن كريم عليك وعلى كل الأخوة بالمنتدى وبارك لنا فيك وفى كل الأخوة بالمنتدى ورمضان كريم

اخى عبدالسلام ابوالعوافي يعجبنى هذا الأسلوب السهل الممتنع

اخى العزيز / ناصر سعيد بدلا عن -1 اكتب -4 Else If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _ And (c.Value < Cells(صف_الدرجات, c.Column) Or Cells(c.Row, c.Column - 1) < Cells(صف_الدرجات, c.Column - 1) Or Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ") Then If Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ" Then N = N + 1

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

اخي اسامة .. الملف يشتغل تمام معي فكرة العمل انه يقوم بتامين الخلايا ( الخميس الماضي وماقبله ) عند فتح الملف وايضا يقوم بتلوين الخلايا بلون مختلف كما في الصورة اضغط علي Debug وخد سكرين شوت للكود لاعرف المشكلة .. وايضا اخبرني عن اصدار الاوفيس

السلام عليكم احسنت اخي عبد السلام فكرة ملفك قريبة جدا من ملفي مع العلم تم التجربة السريعة مادة الحاسب الآلي القاضي2.rar

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

اخي الكريم ابو ادهم تم ارفاق حل المشكلة في المشاركة السابقة تقبل تحياتي

تفضلو طريقة البحث عن طريق الا Spreadsheet التى ذكرها الاخ عمر قمت بعمل مثال بسيط لجلب البيانات المفلترة الى الفورم ووضعها داخل Spreadsheet وطريقة اضافة هذه الاداة كما بالصور الموضحة والكود المستخدم داخل الفورم في حدث التغيير للتكست بوكس Private Sub TextBox1_Change() Dim last As Long Dim last2 As Long last = Spreadsheet1.ActiveSheet.Range("a10000").End(xlUp).Row Application.ScreenUpdating = False If TextBox1.Text = "" Then Spreadsheet1.ActiveSheet.Range("a1:k" & last).ClearContents Else Spreadsheet1.ActiveSheet.Range("a1:k" & last).ClearContents ActiveSheet.Range("$A$2:$K$2000").AutoFilter Field:=5, Criteria1:="" & TextBox1.Text & "*", _ Operator:=xlAnd last2 = ActiveSheet.Range("a10000").End(xlUp).Row Sheet1.Range("a1:k" & last2).Copy Spreadsheet1.ActiveSheet.Range("a1").Paste Application.CutCopyMode = False ActiveSheet.AutoFilterMode = False Application.ScreenUpdating = True End If End Sub تم ارفاق المثال للتوضيح المرفق يعمل لدى جيدا لا اعلم توافقه مع جميع الاصدارات تقريبا تحتاج اوفيس2003 بالاساس او الملف OWC11.DLL تحديدا لمن يعاني من مشاكل وعدم عمل الملف بالشكل الامثل يرجى تحميل الملف الثاتي بالمرفقات به الشرح والاداة وبرنامج تسجيل الاداة تقبلو تحياتي new list Yasser.rar OWC11.rar

رمضانكم كريم أعاده الله علينا و عليكم بالخير و بالبركات

كل عام والجميع بالف خير

الاخ alyfahem Sub kh_Filter() ' Dim LR As Long 10 With Sheet2 20 .Range(.Cells(9, 1), .Cells(Rows.Count, Columns.Count)).ClearContents 30 End With 40 With Sheet1 50 LR = .Cells(.Rows.Count, "AF").End(xlUp).Row 60 .Range("AD6:BH" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet2.Range("A1:A2"), CopyToRange:=Sheet2.Range("C9"), Unique:=True 70 End With 80 Range("a3").Select 90 LR = Cells(Rows.Count, "AF").End(xlUp).Row 100 ActiveSheet.PageSetup.PrintArea = Range("b2:AB" & LR).Address ' End Sub السطر 20 يمسح منطقة اخراج البيانات قبل الفلتره من بداية السطر 9 حتي نهاية ترقيم الورقة السطر 50 لتحديد رقم اخر صف في قاعدة البيانات السطر 60 كود للتصفية المتقدمة يحدد فيه مدي قاعدة البيانات ومنطقة مدي شروط التصفية وايضا مدي مخراجات ناتج التفية السطر 90 لتحديد رقم اخر صف في مدي المخراجات السطر 100 يقوم بطباعة مدي المخرجات

شاء ربنا ان اكون اول من يرد على العملاق الكبير عمر الحسيني يجزيك الله كل خير تمام التمام .. كمل جميلك واشرحه

الاخ ناصر سعيد لقدروفقن الله وعرفت المشكله وهي مسح منطقة الاخراج قبل الفلتره فيكون الكود كالتالي تم اضافة كومبوبكس لأختيار التقدير وتم تعديل التقيرات في الصفحة الرئيسية لتشمل كل التقديرات لتوضيح عمل الكود Sub kh_Filter() ' Dim LR As Long With Sheet2 .Range(.Cells(9, 1), .Cells(Rows.Count, Columns.Count)).ClearContents End With With Sheet1 LR = .Cells(.Rows.Count, "AF").End(xlUp).Row .Range("AD6:BH" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet2.Range("A1:A2"), CopyToRange:=Sheet2.Range("C9"), Unique:=True End With Range("a3").Select LR = Cells(Rows.Count, "AF").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = Range("b2:AB" & LR).Address ' End Sub انظر المرفقات كود فلتره 9.rar مع حبي وتقديري

كل عام وانتم بخير الحمد لله الذي بلغنا شهر رمضان الكريم

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

و بارك الله فيك ايضا و كل عام و انتم بخير اخي الكود واضح و بسيط و غير معقد y = year_year y متغير و قيمته حقل year_year في نموذج pr = [product name] pr عبارة عن متغبر و قيمته حقل = [product name] في نموذج ايضا ثم نطلب من الاكسس اذا كان عدد صفوف في جدول Month target يساوي فيه ( السنة و اسم المنتوج مع السنة و اسم المنتوج في نموذج في نفس صف) اكثر من صفر، ينفذ امر Undo و و يعرض رسالة كذا كذا كذا و الا كمل شغله . على فكرة: لماذا اسم المنتج محاصر بين قوسين مربع و سنة لا؟ لان اسم المنتج يحوي على فاصلة و الافضل حصار كلا هما بن قوسين مربع [].

وكل عام وانتم بخير

كل عام وانتم بخير اعاننا الله وإياكم على صيامه وقيامه

جزاك الله عنا كل خير واسكنك الفردوس الاعلى آمين

بعد اذنكم .. لما لا تجرب هذه المعادلة =INT((E2+10)/20)

بارك الله فيك اخي جلال و في الاخ خيزاني المتميز دائما شككككككككككككرا

تفضل ما تريد (الصفحة 3) تم التعديل على الملف Code or ID advanced 1.rar

جرب المرفق مرتبات البنك.rar

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

تفضل اخي علما بان تم تغير اسم جدول year الى yyear و كذالك اسماء حقول في جداول بهذالاسم لان year كلمة محجوزة في اكسس و اليك المرفق New Microsoft Access Database1.zip

السلام عليكم هذا كود من أعمال الأستاذ الكبير عبدالله باقشير حفظه الله ورعاه أحببت أن اطرحه في موضوع كي يستفيد منه الجميع في أول الكود تحط الشروط المراده * بداية البيانات بدون رؤس الاعمدة * الاعمدة المراد عمل عليها جمع بالامكان تحديد الاعمده اما بشكل فردي وهو "$A$1,$C$1,$F$1" أو بشكل مدى من الى هكذا "$A$1:$G$1" أو بشكل مدى متقطع هكذا "$A$1,$C$1,$E$1:$H$1,$i$1:$K$1" ******************************************************************** الكود ينشاء صف وبه الجمع وبعد الانتهاء من وضع معاينة الطباعه يحذف الصف ******************************************************************** الكود يوضع في مودويل '**************************************** ' بداية البيانات بدون رؤس الأعمدة Private Const Row_Star As Integer = 2 '**************************************** 'الاعمدة المراد جمع قيمها في نهاية فواصل الصفحات Private Const C_N As String = "$A$1,$C$1,$D$1:$F$1" Sub Ali_Sum_Page() Dim Ar() As Integer Dim Rng As Range, Cc As Range Dim C As Range, Cr As Range Dim iCont As Integer Dim i As Integer, ii As Integer Dim r1 As Integer, r2 As Integer Dim Cv As Integer, L_C As Integer ''''''''''''''''''' For Each Cc In Range(C_N) L_C = Cc.Column Next With Cells.Worksheet With .PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" End With .ResetAllPageBreaks .Range("A65536").Select .Cells(Row_Star, "A").Select iCont = .HPageBreaks.Count If iCont = 0 Then Exit Sub ''''''''''''''''''''''' ReDim Ar(1 To iCont) For i = 1 To .HPageBreaks.Count ii = .HPageBreaks(i).Location.row Ar(i) = ii Next ''''''''''''''''''''''' r1 = Row_Star For i = 1 To iCont ii = Ar(i) - 1 With .Range("A" & ii).Resize(1, L_C) .EntireRow.Insert With .Offset(-1, 0) L_r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row If Rng Is Nothing Then Set Rng = .Cells Else Set Rng = Union(Rng, .Cells) r2 = ii - 1 For Each C In Range(C_N) Cv = C.Column .Cells(1, Cv) = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(r2, Cv))) Next r1 = r2 + 2 End With End With Next For Each Cr In Range(C_N) Cv = Cr.Column With .Cells(L_r, Cv) .Value = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(L_r - 1, Cv))) .Interior.ColorIndex = 6 End With Next End With '''''''''''''''''''''' If Not Rng Is Nothing Then With Rng .Interior.ColorIndex = 6 .Worksheet.PrintPreview Range("A" & L_r).EntireRow.Delete .EntireRow.Delete End With End If ''''''''''''''''''''''' Erase Ar Set Rng = Nothing: Set Cc = Nothing Set Cr = Nothing: Set C = Nothing End Sub والسلام عليكم

الاخ الاستاذ الحبيب أبو حنين اشكرك على التشجيع والمرور الكريم جزاك الله كل خير الاخ الفاضل ايهاب سعيد ماذ تقصد بعنواين الصفوف حسب مافهمت جرب التعديل التالي مجاميع الصفحات حسب عناوين الصفوف في العمود A التي باللون الاحمر في معاينة الطباعه '**************************************** ' بداية البيانات بدون رؤس الأعمدة Private Const Row_Star As Integer = 2 '**************************************** 'الاعمدة المراد جمع قيمها في نهاية فواصل الصفحات Private Const C_N As String = "$B$1,$C$1,$D$1:$F$1" Sub Ali_Sum_Page() Dim Ar() As Integer Dim Rng As Range, Cc As Range Dim C As Range, Cr As Range Dim iCont As Integer Dim Arc As Variant Dim P_c Dim i As Integer, ii As Integer Dim r1 As Integer, r2 As Integer Dim Cv As Integer, L_C As Integer ''''''''''''''''''' On Error Resume Next Arc = Range(C_N).Address(0, 0) P_c = Range(Mid(Arc, 1, 2)).Column For Each Cc In Range(C_N) L_C = Cc.Column Next With Cells.Worksheet With .PageSetup .PrintTitleRows = "$1:$1" .PrintTitleColumns = "" End With .ResetAllPageBreaks .Range("A65536").Select .Cells(Row_Star, "A").Select iCont = .HPageBreaks.Count If iCont = 0 Then Exit Sub ''''''''''''''''''''''' ReDim Ar(1 To iCont) For i = 1 To .HPageBreaks.Count ii = .HPageBreaks(i).Location.row Ar(i) = ii Next ''''''''''''''''''''''' r1 = Row_Star For i = 1 To iCont ii = Ar(i) - 1 With .Cells(ii, P_c).Resize(1, L_C) .EntireRow.Insert With .Offset(-1, 0) L_r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row If Rng Is Nothing Then Set Rng = .Cells Else Set Rng = Union(Rng, .Cells) r2 = ii - 1 For Each C In Range(C_N) Cv = C.Column .Cells(1, Cv) = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(r2, Cv))) With Cells(.row, 1) .Value = WorksheetFunction.CountA(Range(Cells(r1, Cv), Cells(r2, Cv))) .Interior.Color = RGB(255, 0, 0) End With Next r1 = r2 + 2 End With End With Next For Each Cr In Range(C_N) Cv = Cr.Column With .Cells(L_r, Cv) .Value = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(L_r - 1, Cv))) With Cells(L_r, 1) .Value = WorksheetFunction.CountA(Range(Cells(r1, Cv), Cells(L_r - 1, Cv))) .Interior.Color = RGB(255, 0, 0) End With .Interior.ColorIndex = 6 End With Next End With '''''''''''''''''''''' If Not Rng Is Nothing Then With Rng .Interior.ColorIndex = 6 .Worksheet.PrintPreview Range("A" & L_r).EntireRow.Delete .EntireRow.Delete End With End If ''''''''''''''''''''''' Erase Ar Set Rng = Nothing: Set Cc = Nothing Set Cr = Nothing: Set C = Nothing End Sub Kh_Sum_Pages_A.rar