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

نعم يمكن استخدم الارتباط التشعبي https://www.google.com/maps/place/28°46'11.5"N 30°53'56.4"E db1.mdb

تفضل تم تعديل المثال اعلاه حسب طلبك Access2.mdb

تم التعديل قليلاً على الملف من حيث الطباعة( يقوم بطباعة كل 4 بيانات على ورقة مستقلة) الطباعة ديناميكية حسب عدد البيانات Dim Source As Worksheet Dim Target As Worksheet Dim Simlpe As Worksheet Dim i%, Cunt%, Ro%, k%, Position%, m% '+++++++++++++++++++++++++++++++++ Sub debut() Set Source = Sheets("Source") Set Target = Sheets("Target") Set Simple = Sheets("Simple") End Sub '+++++++++++++++++++++++++++++++++++ Sub copy_rg(ByVal src As Worksheet, _ ByVal Tg As Worksheet, ByVal Rg_name$, ByVal Rg_where$) src.Range(Rg_name).Copy With Tg.Range(Rg_where) .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub Copy_Tables() debut Target.Cells.Clear Ro = Source.Cells(Rows.Count, 2).End(3).Row - 1 Cunt = (Ro \ 2) + 1 k = 1 For i = 1 To Cunt Call copy_rg(Sheets("Simple"), Sheets("Target"), _ "Simple_Rg", "B" & k) k = k + 7 Next Application.CutCopyMode = False End Sub '++++++++++++++++++++++++++++++ Sub fil_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Copy_Tables m = 1 For Position = 2 To Ro + 1 Step 2 With Source.Cells(Position, 2).Resize(, 4) .Copy Target.Cells(m, 3).PasteSpecial _ Paste:=12, Transpose:=True .Offset(1).Copy Target.Cells(m, 6).PasteSpecial _ Paste:=12, Transpose:=True End With m = m + 7 Next Print_areas With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With Target.Cells(1, 2).Select End Sub '++++++++++++++++++++++++++++++++ Sub Print_areas() Dim x, Rg_last As Range, y% Dim k Sheets("target").ResetAllPageBreaks x = Sheets("target").Cells(Rows.Count, 2).End(3).Row If x < 8 Then Sheets("target").PageSetup.PrintArea = _ Sheets("target").Range("A1:F4").Address Exit Sub End If Set Rg_last = Sheets("target"). _ Range("c" & x - 1).Resize(10).Find("*") If Not Rg_last Is Nothing Then y = Rg_last.Row + 1 Else y = x - 6 End If Sheets("target").PageSetup.PrintArea = _ Sheets("target").Range("A1:F" & y).Address For k = 13 To y Step 14 Sheets("target").HPageBreaks.Add Before:=Rows(k + 1) Next End Sub الملف معدلاً Ahlawi_New.xlsm

السلام عليكم تفضل اخي الكريم لعرض التقرير Dim strWhereCondition As String If Not IsNull(Me.t1) Then strWhereCondition = strWhereCondition & " AND sub='" & Me.t1.Value & "'" End If If Not IsNull(Me.t2) Then strWhereCondition = strWhereCondition & " AND [ÇáãæÏíá]='" & Me.t2.Value & "'" End If If Len(strWhereCondition) > 0 Then strWhereCondition = Mid(strWhereCondition, 6) End If DoCmd.OpenReport "mach", acViewPreview, WhereCondition:=strWhereCondition DoCmd.Close acForm, Me.Name ولطباعة التقرير Dim strWhereCondition As String If Not IsNull(Me.t1) Then strWhereCondition = strWhereCondition & " AND sub='" & Me.t1.Value & "'" End If If Not IsNull(Me.t2) Then strWhereCondition = strWhereCondition & " AND [ÇáãæÏíá]='" & Me.t2.Value & "'" End If If Len(strWhereCondition) > 0 Then strWhereCondition = Mid(strWhereCondition, 6) End If DoCmd.OpenReport "mach", WhereCondition:=strWhereCondition DoCmd.Close acForm, Me.Name UP-test.rar تحياتي

لا جاجة لجماية المعادلات اذا استخدمت هذا السطر في الكود بعد ازالة كلمة Rem من أمامه لأن اامعادلات تتجول الى قيم عادية Rem Range("G11:Aj313").Value = Range("G11:Aj313").Value

وهل من الصغب جداً الضغط على الزر كل يوم (أو عند اي تعديل للبيانات ) مرة واحدة

جرب هذا الكود (في حال حذف اي معادلة او العبث بها عن طريق الخطأ قم بتشغيله) Option Explicit Sub Formula_To_Code() Dim My_Str$: My_Str = """مغادرة""" Range("G11:Aj313").Formula = _ "=IF(G$10=$D11,My_Str,IF(AND(G$10>=$C11,G$10<=$D11-1),$E11,0))" '================ هذا السطر اختياري لتثبيت المعادلات _ ===================== والحصول على القيم فقط لتخفيف حجم الملف _ ======================= من أوله Rem اذا اردت ذلك احذف كلمة Rem Range("G11:Aj313").Value = Range("G11:Aj313").Value '================================================= End Sub

جرب هذا الملف Bander.xlsx

أهلاً وسهلاً بك و بأهل مصر (الحبيبة أم الدنيا) كلها دعاؤكم للثورة اللّبنانية فقط (كما انتصرت عندكم تنتصر في وطني لبنان) هذا الماكرو (الملف مرفق ) فقط اضغط الزر "Get _Names" Dim Source As Worksheet Dim Target As Worksheet Dim Simlpe As Worksheet Dim i%, Cunt%, Ro%, k%, Position%, m% '+++++++++++++++++++++++++++++++++ Sub debut() Set Source = Sheets("Source") Set Target = Sheets("Target") Set Simple = Sheets("Simple") End Sub '+++++++++++++++++++++++++++++++++++ Sub copy_rg(ByVal src As Worksheet, _ ByVal Tg As Worksheet, ByVal Rg_name$, ByVal Rg_where$) src.Range(Rg_name).Copy With Tg.Range(Rg_where) .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub Copy_Tables() debut Target.Cells.Clear Ro = Source.Cells(Rows.Count, 2).End(3).Row - 1 Cunt = Ro \ 2 If Cunt Mod 2 = 1 Then Cunt = Cunt + 1 End If k = 1 For i = 1 To Cunt Call copy_rg(Sheets("Simple"), Sheets("Target"), _ "Simple_Rg", "B" & k) k = k + 6 Next Application.CutCopyMode = False End Sub '++++++++++++++++++++++++++++++ Sub fil_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Copy_Tables m = 1 For Position = 2 To Ro Step 2 With Source.Cells(Position, 2).Resize(, 4) .Copy Target.Cells(m, 3).PasteSpecial _ Paste:=12, Transpose:=True .Offset(1).Copy Target.Cells(m, 6).PasteSpecial _ Paste:=12, Transpose:=True End With m = m + 6 Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With Target.Cells(1, 2).Select End Sub الملف مرفق Ahlawi.xlsm

السلام عليكم اليك بعض النصائح تجنك الوقوع في مشكلة تعارض الكتابة: 1- قم بتقسيم قاعدة البيانات الي قاعدة أمامية بها النماذج والتقارير والاستعلامات و .... وقاعدة خلفية تحتوي علي الجداول فقط 2- اجعل قاعدة الخلفية (التي تحوي الجداول فقط هي القاعدة التي يتم مشاركتها مع الجميع) 3- وزع القاعدة الأمامية والتي بها النماذج والتقارير و..... علي كل جهاز نسخة. 4- اجعل النموذج الخاص بملء البيانات داخل الجدول غير منضم واجعل ارسال البيانات بشكل كلي من خلال زر حفظ مثلا يتم الضغط عليه مرة واحدة بعد الانتهاء من ملء البيانات المطلوبة. (هذا سيقلل كثيرا من حدوث تعارض في ارسال البيانات لقلة احتمالية أن يضغط مستخدمان في نفس الوقت علي زر حفظ) 5- اضابط خاصية اغلاق السجل الي حقل محرر لكل النماذج الخاصة بادخال البيانات كما بالصورة وفي النهاية أتمني لي ولك التوفيق والسداد.

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

تم تضييق الهامشين (الأعلى والأسقل) قليلاً واصيح بالامكان العمل مع 16 اسم في كل ورقة مما يوفر كمية لا باس بها من الورف (بالنسبة لـــ 40 الف اسم) حوالي 350 ورقة Ahlawi_New_16.xlsm

كشف الحساب موجود في النسخة الأخيرة: وتم تحديث النسخة الأخيرة في الموضوع الأصلي

اللهم انصر لبنان وأهل لبنان اللهم امين يارب

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

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

تفضل ..... ولكن عنوان الموضوع يجب ان يكون موافق لما في داخل الموضوع ( قوانين المنتدى ) ... بارك الله فيك استخلاص تاريخ الميلاد.rar

احسنت ابو البشر يجب الالتزام بقوانين المنتدى .وعدم طرح اكثر من سؤال في نفس الموضوع . ويرجى إنشاء موضوع جديد

بعد اذن استاذ أحمد زمان طبعاً ...يمكنك استخدام هذا الكود فى حدث الصفحة لتكبير حجم الخط فى القائمة المنسدلة وأعتقد ان هذا يكفى فى هذه المشاركة فيجب الغلق فمن الطبيعى والمفترض ان تكون المشاركة لطلب واحد بارك الله فيكم Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo Skipper Dim x As Long x = 100 If Target.Validation.Type = xlValidateList Then x = 130 Skipper: ActiveWindow.Zoom = x End Sub _البرنامج 1-7-2020 - نسخة (2) (1).xls

سليم حاصبيا شكراً جزيلاً هذا هو المطلوب بارك الله فيك وزاد علمك ونفع بك (أحسنت)

الماكرو المطلوب (عملية انشاء الزر اتركها لك) Option Explicit Sub Replace_S_by_Nothing() Range("A9").CurrentRegion.Replace "س", "" Range("J9:j26").Copy Range("M9").PasteSpecial (12) Application.CutCopyMode = False Range("D9").Select End Sub

للأسف فد جربت ما تريده لكن لم استطع ان أحصل على اكثر من 14 اسم على ورقة واحدة (لأن البيانات تخرج منقسمة) Ahlawi_New_14.xlsm

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

اليك الملف مع الكود fORMULA_TO VBA.xlsm

تم التعديل على الكود Sub Formula_To_Code() Range("G11:Aj313").Formula = _ "=IF(G$10=$D11,""مغادرة"",IF(AND(G$10>=$C11,G$10<=$D11-1),$E11,0))" '================ هذا السطر اختياري لتثبيت المعادلات _ ===================== والحصول على القيم فقط لتخفيف حجم الملف _ ======================= من أوله Rem اذا اردت ذلك احذف كلمة Rem Range("G11:Aj313").Value = Range("G11:Aj313").Value '================================================= End Sub

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

بارك الله فيك الواحد حاسسه حاله بحرب (نسف 🙂) وتدمير لتنسيق فهارس أشكر لك جهودك الدائمة والمتفانية دوماً دمتم بخير

استاذ محمد القدسي جرب هذا المرفق وان شاء الله لا يوجد خطا SearchSort-6.rar

نفضل با سيدي Yasser.xlsm

السلام عليكم ورحمة الله وبركاته،،، يعطيك العافية أخي الغالي شحادة قمت بفهرسة للأعلام والأحاديث والآيات القرآنية عن طريق (إضافة البيان البحثية) وحقيقة السرعة في الإنجاز ممتازة، ومهم بالنسبة لي أيضاً، لكن يوجد لديَّ عدة ملاحظات وجدتها خلال عملي، وهما: عند تحديث أي فهرس بعد إجراء الفهرسة الآلية أو اليدوية يقوم بنسف كل التنسيقات لهذا الفهرس ويعيده لوضعه الأول عند الإنشاء. لا يوجد ارتباط تشعبي للأرقام عند إدراج الفهارس سواء الآلية أو الآلية، مع ملاحظة أنه عند الفهرسة بالإشارات المرجعية عن طريق (إدراج جدول محتويات بالإشارات المرجعية) وجدت أنني أستطيع تحديث الأرقام تلقائياً عند الضغط على F9، ولا يتم تغيير في التنسيق المعمول فيه بالجدول. عند تكرار لاسم الإشارة المرجعية يوجد فاصل لرقم الصفحات بالفاصلة الإنجليزية (,) (10, 15, 90) والصح أن تكون (10، 15، 90). لكم مني كل التقدير

السلام عليكم و رحمة الله وبركاته تم اضافة عمود للمقاس تم عمل قائمة منسدلة للصنف تم عمل قائمة منسدلة للمقاس في g1 تم اضافة دالة للبحث عن كلمة بيع في نوع الفاتورة اذا وجد بيع - يقوم بخصم الكمايات لا يوجد بيع يقوم باضافة الكميات فقط زر واحد للعمليات اضافة او خصم حسب نوع الفاتورة مع التحية _البرنامج 1-7-2020 - نسخة (2).xls

الشكر لله اخى حسين اما لماذا توقف عند الرقم 100 فهذا لان السطر الثانى من الكود لقطع اول رقمين يمكنك زياده الفورمات للاصفار لاربعه كما الكود التالى وزياده القطع فالسطر الثانى dl = Nz(DMax("FATORA_NO", "101"), 0) rd = Int(Right([dl], 4)) + 1 strLeft = Left(dl, 3) Me.[FATORA_NO] = strLeft & Format(rd, "0000") Me.Refresh ويمكنك استبدال الكود والاستغناء عن الفورمات كالتالى dl = Nz(DMax("FATORA_NO", "101"), 0) rd = Int(Right([dl], Len(dl) - 3)) + 1 strLeft = Left(dl, 3) Me.[FATORA_NO] = strLeft & rd Me.Refresh بالتوفيق

بعد إذن الخبير husamwahab المحترم تم تعديل النموذج لحساب القيمة وتجميعها تحياتى حذف الزر جيد-2.accdb

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

مرفق ملف اخر يمنع اضافة اعمدة او صفوف ويمنع ايضاً حذفها كبفية عمل ذلك اتركها مؤقتاً "فزورة" ربما يكتشفها البعض Privent_New_Cols_Rows.xlsx

من رخصة استاذ حسام تفضل على طريقتي انشأت نموذج وسميته Filter وبدوره تستطيع فلترة اي محافظة وطباعة الناتج بتقرير DB2.rar

عليكم السلام تفضل هذه المحاولة ارجو ان تكون موفقة ملاحظة : تم التعديل على قاعدة البيانات بطريقة ارجو ان لا تسبب لك مشكلة DB2.rar

انشئ قاعدة جديدة وصمم نموذج وبه زر وضع تحت حدث عندالنقر على الزر هذا الكود ..... Dim objAcc As Access.Application Set objAcc = GetObject("C:\Users\ACER\Desktop\data1.accdb") objAcc.DoCmd.OpenQuery "Qre1" objAcc.Application.Quit Set objAcc = Nothing

حياك الله وبالتوفيق ,,,,,

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

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

تأكد من اعدادات اللغة كما بالصور تحياتي

وعليكم السلام ورحمة الله وبركاته اخي الكريم نحن هنا لسنا في نتحدي مع احد ولكن كلنا اخوة نحاول مساعدة بعض ووالله استفدت من هذا المكان كثيرا جدا واحاول فقط رد الجميل سنفرض انا لدينا كومبوبوكس باسم Combo11 نضع الامر التالي به If Me.Combo11.Value = 1 Then myCriteria = "" myCriteria = "(" myCriteria = myCriteria & "[التاريخ] between #" & Format("01/01/2020", "mm/dd/yyyy") & "# and #" & Format("31/03/2020", "mm/dd/yyyy") & "#" myCriteria = myCriteria & ")" ElseIf Me.Combo11.Value = 2 Then myCriteria = "" myCriteria = "(" myCriteria = myCriteria & "[التاريخ] between #" & Format("01/04/2020", "mm/dd/yyyy") & "# and #" & Format("30/06/2020", "mm/dd/yyyy") & "#" myCriteria = myCriteria & ")" ElseIf Me.Combo11.Value = 3 Then myCriteria = "" myCriteria = "(" myCriteria = myCriteria & "[التاريخ] between #" & Format("01/07/2020", "mm/dd/yyyy") & "# and #" & Format("30/09/2020", "mm/dd/yyyy") & "#" myCriteria = myCriteria & ")" ElseIf Me.Combo11.Value = 4 Then myCriteria = "" myCriteria = "(" myCriteria = myCriteria & "[التاريخ] between #" & Format("01/10/2020", "mm/dd/yyyy") & "# and #" & Format("31/12/2020", "mm/dd/yyyy") & "#" myCriteria = myCriteria & ")" End If Debug.Print myCriteria Me.[التخصص]![الادخال Subform].Form.Filter = myCriteria Me.[التخصص]![الادخال Subform].Form.FilterOn = True gstorm_2.rar تحياتي

السندات الإصدار الثاني تم إجراء التالي : إصلاحات وتحسينات . اختيار تفقيط العملة المناسب لبلدك يدوياً . السندات 2.1.rar

الاخوه الاعزاء الموضوع الذي اتقدم به اليوم هو كيفية عمل نسخه احتياطيه للملف في اكثر من درايفر( c,d f,e) الرجاء قراءة الشرح قبل تحميل المرفق اولا: يوجد بالمرفق فولدرين تحت اسم (ahmad 1,ahmad 2) بالاضافه للملف الاصلي نظرا لانه عند تنزيل الويندوز في بعض الاحيان تختلف تقسيمات الدرايفرز فانني اخترت تنفيذ النسخه الاحتياطه في درايفر c , d اما من لديه اربع درايفرات فيمكنه عمل نسخ احتياطيه اخرى في درايفر f , e بسهوله ثانيا: الية عمل النسخه كلاتي 1 حفظ الملف الاصلي 2 عمل نسخه احتياطيه في كل من درايفر c ,d وهذا طبعا عند اختيار yes اما عند اختيار no فانه سيعمل فقط على حفظ الملف الاصلي فقط دون عمل تحديث للنسخ الاحتياطيه ثالثا: المطلوب حتى يتم تنفيذ العمل بالشكل الصحيح 1 نقل فولدر ahmad 1 الى درايفر c 2 نقل فولدر ahmad 2 الى درايفر d 3 نقل الملف الاصلي الى اي مكان ترغب به رابعا: طريقة التنفيذ 1 فتح الملف الاصلي المرفق 2 النقر على زر النسخه الاحتياطيه والانتظار قليلا حتي يتم التنفيذ ويتم غلق الملف تلقائيا 3 الذهاب الى فولدر ahmad 1,ahmad 2 ستجد الملف موجود هناك 4 العوده الى الملف الاصلي ومحاولة كتاب اي شئ به ومن ثم النقر على الزر مره اخرى ( اختياري) 5 الذهاب الى فولدر ahmad 1,ahmad 2 ستجد التغيرات التي تمت في الملف الاصلي هي نفسها الموجوده في النسخ الاحتياطيه خامسا : محظورات الاستخدام 1 يجب دائما استخدام الملف الاصلي ولا يمكن باي حال استخدام ملفات النسخ الاحتياطيه كملف اصلي الا في الحالات التاليه: أ في حالة فقدان الملف الاصلي واردت ان تستخدم النسخ الاحتياطيه فقم بفتح ملف النسخه وقم بعمل حفظ باسم الى اي مكان تريده وفي هذه الحاله يعتبر الملف الذي قمت بعمل حفظ باسم له هو الملف الاصلي الذي ستعمل به ب كما يمكن ايضا استخدام ملف النسخ كملف رئيسي ولكن دون استخدام زر الامر (نسخه احتياطيه)والاكتفاء فقط بحفظ الملف لانه بطبيعة الحال لا يمكن عمل نسخه احتياطيه لملف النسخه نفسها سادسا : التغييرات المسموح بها 1 يمكنك تغيير اسماء الفولدرز الى اي اسم تريده ولكن بشرط ان تغير الاسم الموجود بالكود نفسه 2 وحتى ان اردت ان تضع الفولدر داخل فولدر فيمكن هذا ولكن ايضا بشرط ان يتم نقل path ووضعه كما هو بالكود بين علامات التنصيص سابعا : مبروك عليكم حلول عيد الفطر السعيد( وكل عام وانتم بخير) نسخه احتياطيه.rar

مثال على التحكم في قسم التفاصيل . - التحكم بعدد الأسطر في الصفحة لـ Dream_Works . - التحكم في الصفحة الأخير من التقرير لـ Accessna . - تصميم المثال ابتداء وبياناته لـ ابوابراهيم . أفكار جميلة وأكواد قوية ، احرصوا على الإطلاع عليها . ReportDetailSectionControl.rar