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

اتفضل املف لعله يفى بالغرض وصولات البيع.xlsm

جرب تلوين.xlsm

السلام عليكم ورحمة الله ضع هذا الكود فى حدث الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Cells(Target.Row, 4) <> "" Then Range("B2:D21").Sort key1:=Range("D2"), order1:=xlAscending End If If Cells(Target.Row, 10) <> "" Then Range("H2:J21").Sort key1:=Range("J2"), order1:=xlAscending End If If Cells(Target.Row, 16) <> "" Then Range("N2:P21").Sort key1:=Range("P2"), order1:=xlAscending End If End Sub

1-ليس من الضرورة رفع ملف يجتوي على اكثر من 1500 صف لان الماكرو الذي يعمل على صف واحد بستطيع العمل على الوف الصفوف 2- تم اختصار الملف الى حوالي 80 صف لمتابعة عمل الماكرو 3-الكود Option Explicit Dim sh As Worksheet Dim New_sh As Worksheet Dim lr%, Cont#, i%, x%, k% Dim SectionName As Range Const How_Many = 20 '+++++++++++++++++++++++++++++++ Sub Del_sheets() Application.DisplayAlerts = False For Each sh In Sheets If sh.Name Like "Section*" Then sh.Delete End If Next Main.Select Application.DisplayAlerts = True End Sub '++++++++++++++++++++++++++++++ Sub insert_Sheets() Del_sheets Set SectionName = Main.Range("D3:K3") lr = Main.Cells(Rows.Count, 3).End(3).Row Cont = (lr - 1) / How_Many If Int(Cont) <> Cont Then Cont = Cont + 1 End If Cont = Int(Cont) For i = 1 To Cont Sheets.Add(, Sheets(Sheets.Count)).Name = "Section_" & k * How_Many + 1 k = k + 1 SectionName.Copy With ActiveSheet.Range("D3") .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With Next Application.CutCopyMode = False Main.Select End Sub '++++++++++++++++++++++++++++++++++++ Sub fil_data() Application.ScreenUpdating = False insert_Sheets x = 4 For Each New_sh In Sheets If New_sh.Name Like "Section*" Then Main.Range("D" & x).Resize(How_Many, 9).Copy New_sh.Range("D4").PasteSpecial (xlPasteAll) New_sh.Range("D4").PasteSpecial (8) x = x + How_Many End If Next Application.ScreenUpdating = True Main.Select End Sub 4-الملف مرفق Taksim_Ahmad.xlsm

اعتقد انه بالفلترة افضل من الحلقات التكرارية Sub cutpaste_Rows() Application.ScreenUpdating = False Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set srcWS = Sheets("sheet1") Set desWS = Sheets("sheet2") With srcWS .Cells(6, 1).CurrentRegion.AutoFilter 3, Range("a2").Value .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) .AutoFilter.Range.Offset(1).EntireRow.Delete .Range("A1").AutoFilter End With Application.ScreenUpdating = True End Sub تلوين (1).xlsm

وعليكم السلام -تفضل هذا هو الكود المطلوب Private Sub CommandButton2_Click() With Me.Yh_ListFind Me.TextBox1.Value = .ListCount - 1 End With End Sub

اتفضل الشيت لعله بفى بالغرض اما بالنسبة شبت الدمج انظر اليه قد التعديل على الكود نسخة من تلوين 222.xlsm

وعليكم السلام ورحمة الله وبركاته ضع الكود التالي في وحدة نمطية جديدة Public Function XXPicture() Dim XPicture As String XPicture = Application.CurrentProject.Path & "/01.jpg" XXPicture = XPicture End Function وضع الكود التالي في النماذج Private Sub Form_Load() Me.Picture = XXPicture End Sub مع تغيير اسم الصورة ووضعها بجوار البرنامج تحياتي

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

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

وعليكم السلام قم بانشاء ماكرو وقم بتسميته AutoKeys كما بالصوره ثم قم بانشاء ماكرو فرعى بداخله كما بالصوره واكتب به F^ جرب ووافنا بالنتيجه بالتوفيق اخى

وعليكم السلام ... لا يمكن عمل هذا

شكرا لك اخي العزيز اقسم برب العزة اجابة جدا جميلة عاشت اناملك لما عملت وممنون منك جدااا

حبيبى استاذ سليم وهو فى استاذن معلم من تلميذه وهو بنتعلم منكم

بعد اذن الاستاذ وجيه لا استطيع الا أن أعطي ملاحظات لماذا لا نستغني عن الحلقة التكرارية (J) الثانية ؟؟ لأن الحلقات التكرارية ترهق البرنامج اذا كانت البيانات كبيرة و ذلك باعتماد هذا الكود Sub aa() Dim ws As Worksheet: Set ws = Sheets("Sheet1") Dim sh As Worksheet: Set sh = Sheets("Sheet2") sh.Range("a7:e55") = "" k = 7 lr = ws.Range("a" & Rows.Count).End(xlUp).Row For i = 7 To lr If ws.Range("b2") = ws.Range("c" & i) Then sh.Cells(k, 1).Resize(, 5).Value = _ ws.Range("A" & i).Resize(, 5).Value k = k + 1 End If Next sh.Activate End Sub

هل هذا ما تريد --------->>>> ترقيم متسلسل.accdb

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

اكتب هذا الحدث --------------->>>>> If ((Eval("DLookUp(""[no]and[name_1]and[date_1]"",""[Table1]"",""[no] = Form.[no] and [name_1] = Form.[name_1]and [date_1] = Form.[date_1] "") Is Not Null"))) Then MsgBox "عـفواً ، تم تسجيـل هذا الإسم الكامل بالفعل", vbMsgBoxRtlReading, "منع تكرار" DoCmd.RunCommand acCmdDelete End If

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

طبعاّ بعد اذن استاذنا الكبير إبراهيم ... بارك الله فيك كود ممتاز جعله الله فى ميزان حسناتك تفضل الأمر بسيط جداً ويمكنك تعديله بنفسك ... عليك بتعديل هذه الكلمة من كل الكود xlAscending الى xlDescending

وعليكم السلام-فقط يمكنك استخدام هذه المعادلة =SUBSTITUTE(A2," ","") رفع المسافة الواحدة بين الحرف والرقم.xlsm

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

هلا ومرحبا بأخوي حلبي ، وشكرا على جميل كلماتك 🙂 اخي امين ، خليني اشرح لك ليش تحصل على النتائج اللي في مرفقك ، واخبرك كيف الطريقة الصحيحة : في الحقل 1 ، انت طلبت يجمع لك جميع حقول الاستعلام Q_1 ، بشرط حقل اختباري ، وما في اي شرط ، فحسب لك كل السجلات = 8 ، 2.3.4. نفس رقم 1 ، ولكن الان وضعت شرط ، يا اختباري = العميل ، ويا العميل = اختباري ، ومن نتائج الصورة المرفقة نرى ان اختباري ≠ العميل ، لذا فالنتيجة = صفر. . الشيء الآخر ، في معيار الدالة DCount يجب عليك وضع قيم ثابته وغير متغيرة حتى يكون نتائجك صحيحة ، ولكن لما يكون معيارك في السجل في الاستعلام ، فيكون متغير بتغير قيمته في السجل ، وهذا يعطي نتائج خطأ ايضا ، اذا رأيت استعلاماتي اعلاه ، بتشوف اني عملت كل مجموعة في استعلام خاص ، وهذه لا تتغير لما استعملها في استعلام آخر . وكذلك العلاقة بين المجموعات اعلاه والاستعلام العام ، فهذي العلاقة عبارة عن ربط معيار الحقول : . يعتبر الاستعلام العمود الفقري لجميع انواع قواعد البيانات ، وكلما تعلمت منه اكثر ، كلما اصبحت قاعدة بياناتك افضل واسرع ، وقلت حاجتك الى الكود 🙂 جعفر

تفضل يا صديقي مجرد ان تدخل كود موجود مسبقاُ (من خلال الزر اضافة موظف) تحصل على رسالة خطأ moh_Unique_Code.xlsm

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

الكود يلغى الغاء دمج الخليه التى تقف عليها

الكود لا يعطي الا أول حلية من ما كان مدمجاً

شكرا استاذنا الفاضل على مرورك العطر وبالنسبة لنفطةالغاء الدمج اتفضل الشيت بعد التعديل نسخة من دمج الخلايا عندما تكون لها نفس القيم-1.xlsm ماشاء الله استاذ سليم دائما سباق بالخير جعله الله فى ميزان حسناتك

كود لأرجاع كل شيء كما كان Option Explicit Sub UNMERG() Dim x%, y%, Cel As Range With Range("A1").CurrentRegion For Each Cel In .Cells x = Cel.MergeArea.Rows.Count y = Cel.MergeArea.Columns.Count Cel.UnMerge Cel.Resize(x, y) = Cel.Cells(1, 1).Value Next .Borders.LineStyle = 1 End With End Sub

شكر وتقدير واحترام الاستاذ الكبير سليم والاستاذ الفاضل وجيه

تفضل 🙂 زر لليوم اللي انت فيه ، و زر للأيام اللي تدخلها بين "التاريخ من" الى "التاريخ الى" . . على فكرة ، عدد الموظفين لكل سطر في النموذج الفرعي ، مثل تاريخ 19 اكتوبر ، الشفت الاول ، عندنا : السطر الاول: احالحمد, السعد, السطر الثاني: كاظم, مح الحمد نقدر نتحكم في العدد لكل سطر (طبعا اذا كان السطر طويل ، فطبعا بقية السطر تلقائيا ينتقل للسطر التالي) ، مما يجعل سجلات النموذج الفرعي تطول وتقصر على حسب الاسطر اللي بها 🙂 التحكم من الاستعلام qry_Group_Shifts_by_Dates ، من الرقم اللي يؤشر عليه السهم ، والبرمجة هكذا : الرقم 1 : يعطيك اسم واحد لكل سطر ، الرقم 2 : يعطيك اسمين لكل سطر ، الرقم 3 او اكثر : يعطيك الاسماء بالعدد المكتوب لكل سطر ، الرقم 0 : يعطيك كل الاسماء في سطر واحد (وحتى تقدر ان تحذف الرقم والفاصلة اللي قبله) ، هكذا : S2: Group_Shifts(2,[tbl_Shifts].[nDate]) . والحمدلله قدرت اخلي تحميل النموذج الفرعي اسرع بنسبة 30% (عد لا تسألني كيف حسبتها 🙂 ) جعفر 1281.2.FRm_Refresh.accdb.zip

دائما نتعلم منكم استاذ سليم وجزاكم الله خير الجزاء

رائع استاذ وجيه باقي كود لأرجاع كل شيء كما كان بعد اذنك بلاش الـــ Select دي التي لا فائدة منها Sub aa() Application.DisplayAlerts = False Dim i, J As Integer For J = 1 To 16 For i = 2 To 7 If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _ And Cells(J, i + 1) <> "" Then Range(Cells(J, i), Cells(J, i + 1)).Merge End If Next Next Application.DisplayAlerts = True End Sub

بعد اذن استاذنا سليم واثراء للموضوع انظر الى هذا المرفق نسخة من دمج الخلايا عندما تكون لها نفس القيم-1.xlsm

1- اي نعديلات على الجدول يجب ادراجها في النطاق AA1:AG16 لأن الماكرو يأخذ البيانات من هناك بالنسبة للـــ UNMERGE جرب هذا الماكرو (الصفحة SALIM من هذا الملف ) Option Explicit Sub Mreg_equal_cells() Dim Ro%, i%, k%, t%, n%, ky Dim d As Object Dim Rg As Range Set d = CreateObject("Scripting.Dictionary") Ro = Cells(Rows.Count, 1).End(3).Row For t = 2 To 7 k = 1 Do Until k > Ro i = k: n = 1 Do Until Cells(i, t) <> Cells(i + 1, t) n = n + 1 i = i + 1 Loop Set Rg = Cells(k, t).Resize(n) d(Rg.Address) = "" k = k + n Loop Application.DisplayAlerts = False For Each ky In d.keys Range(ky).Merge Next Application.DisplayAlerts = True d.RemoveAll Next Application.DisplayAlerts = True End Sub '+++++++++++++++++++ Sub No_merge() Range("AA1:AG16").Copy Range("A1") End Sub الملف مرفق الصفحة SALIM bachiri401_MERGE.xlsm

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

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

تفضل -يمكنك استخدام هذه المعادلة فى التنسيقات الشرطية =TRIM(MID(B6,IFERROR(FIND("رخام",B6,1)+0,1),9^9))="رخام" تلوين1.xlsx

المقصد التعديل على كود الاستيراد مثل هذا المرفق New folder.rar

مشاركه مع اخى واستاذى العزيز @husamwahab جزاه الله خيرا حاجه بسيطه على قدى ع حسب ما فهمت قمت بعمل استعلام تحديث وتصفيه القيم على حسب التسلسل الذى تكتبه بالنموذج ثم نقوم باضافه 1 لهذه القيم المصفاه بعد كتابه القيمه بالتسلسل قم بالضغط على زر تحديث لتشغيل الاستعلام UPDATE Home SET Home.تسلسل = [تسلسل]+1 WHERE (((Home.تسلسل)>=[Forms]![نموذج1]![تسلسل])); قمت بالتجربه على جعل جرب ووافنا بالنتيجه بالتوفيق تجربه‌(2).accdb

اليك الملف مع الكود 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

جرب هذا الكود (في حال حذف اي معادلة او العبث بها عن طريق الخطأ قم بتشغيله) 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

تم التعديل قليلاً على الملف من حيث الطباعة( يقوم بطباعة كل 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

السلام عليكم ورحمة الله وبركاته اليوم تحديث جديد لهذا الموضوع الخاص بمستعرض الصور فقط والان المستعرض اصبح لكل الملفات الموجودة فى المجلد الذى تريده التحديث يشمل 1 - لا يقتصر العرض على الصور فقط بل على كل الملفات 2- امكانية استعراض الصور بشكل مكبر داخل البرنامج ( المستعرض ) 3- امكانية نسخ الملفات الى اى مكان داخل الويندوز ( دون الاماكن التى تحتاج الى صلاحيات مثل مجلدات النظام ) 4 - امكانية نقل الملفات الى اى مكان فى الويندوز ( دون الاماكن التى تحتاج الى صلاحيات مثل مجلدات النظام ) 5 - جلب خصائل كل ملف من تاريخ انشاء وتعديل حجم الملف 6 - امكانية اعادة التسمية لاى ملف فى المجلد عن طريق البرنامج 7 - اضافة بروجرس بار فقط اثناء تحميل الملفات من المجلد لاستعراضها 8 - امكانية حذف الملف المختار عن طريق البرنامج 9 - امكانية البحث بالاسم والنوع داخل المجلد والان مع الصور والشرح -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- والان فيديو مبسط لطريقة عمله اتمنى ان يعجبكم اصدقائى وتستفيدون منه ان شاء الله فقط انا فى انتظار ارائكم وملاحظتكم وتحديثاتكم مين عارف يمكن نستخدمه بدل explore.exe 🤣🤣 Gallary.rar

بعد اذن الأخ أحمد وزيادة في اثراء الموضوع يمكن استعمال هذه المعادلة =SUMPRODUCT(0+(MOD(COLUMN($B$6:$V$6)-COLUMN($B$6)+1,3)=0),$B6:$V6) الملف مرفق Mhd_Ahm.xlsx

تفضل المثال وعن طريق المتصفحين ميكروسوفت وجوجل يتم فتح متصفح ميكروسوفت بواسطة ارتباط تشعبي اما بالنسبة لجوجل انظر الكود المسؤول عن ذلك chromePath = """C:\Program Files\Google\Chrome\Application\chrome.exe""" returnValue = Shell(chromePath & " http://www.officena.net/ib/index.php?showforum=89", vbNormalFocus) SendKeys ("{F5}"), True ويجب التنبه لصحة امتداد عنوان برنامج جوجل داخل حاسوبك فتح موقع.rar