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

استكمالا لجهود الزملاء الأعزاء إذا كان لديك أوفيس 2021 أو 365 يمكنك وضع هذه المعادلة في I2 =UNIQUE($B$2:$D$16) أو يمكنك تعديل الإجراء المقدم من أخينا @محي الدين ابو البشر إلى Sub test() Dim a, T As String, i& a = Sheets("aaa").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) T = a(i, 2) & a(i, 3) & a(i, 4) If Not .exists(T) Then .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4)) End If Next i Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2)) = Application.Index(.items, 0, 0) End With End Sub ولوضع كود لكل مادة في العمود الأول يمكنك وضع هذه المعادلة في الخلية A2 مع سحبها لأسفل =IFERROR(INDEX(M$2:M$8,MATCH(B2&C2&D2,J$2:J$8&K$2:K$8&L$2:L$8,0))-1+COUNTIFS(B$2:B2,B2,C$2:C2,C2,D$2:D2,D2),"") بالتوفيق للجميع

عليكم السلام ربما يكون هذا المطلوب بالتوفيق نسبة المبيعات.xlsx

هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb

حتى لا يتعرض موضوعك للإغلاق ، عليك ما يلي :- 1. العنوان المناسب لوصف المشكلة. 2. شرح المطلوب بإيضاح. 3. ارفاق ملف للعمل عليه.

اشكر حضرتك هو المطلوب فعلا

بعد اذن أستاذ @عمر ضاحى تفضل أخي محاولتي حسب مافهمت ووافني بالرد . DD408.accdb

السلام عليكم - حل متواضع date.xlsx

ولتجنب استخدام جملة On Error Resume Next يمكن تعديل الكود بهذا الشكل Sub Test2() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets With ws If .AutoFilterMode Then .AutoFilterMode = False If .FilterMode = True Then .ShowAllData End If End With Next ws Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته جرب الكود التالي عله يفي بالغرض Sub Test() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets If ws.AutoFilterMode Then On Error Resume Next ws.ShowAllData On Error GoTo 0 End If Next ws Application.ScreenUpdating = True End Sub

أخي الفاضل بعد التجربة شغال بامتياز وعمل رائع ممتاز جعله الله في ميزان حساناتك وربي يجازيك خير الجزاء

@kkhalifa1960 لك كل الاحترام والتقدير جزاك الله خيرا

جزيت خيرا كل شيء تمام 100 % تسلم

احبك الله الذي احببتني فيه اخي العزيز @Foksh 😊🌷

اتفضل الحل اولا لحساب العمر وفترة العمل فى دالة واحده اتفضل هذا المديول Function CalcAge(StartDate As Date, EndDate As Date) As String Dim years As Integer Dim months As Integer Dim days As Integer Dim intH As Integer intH = Int(DateDiff("m", StartDate, EndDate)) + _ (EndDate < DateSerial(Year(EndDate), Month(EndDate), Day(StartDate))) years = Int(intH / 12) months = intH Mod 12 days = DateDiff("d", DateAdd("m", intH, StartDate), EndDate) CalcAge = years & " سنة و " & months & " شهر و " & days & " يوم" End Function وهذا الاستعلام شامل كل شئ SELECT tbl_info_fonctionnaire.num, tbl_info_fonctionnaire.nom_arabe, tbl_info_fonctionnaire.prenom_arabe, tbl_info_fonctionnaire.date_naissance, tbl_info_fonctionnaire.date_premiere_grade_poste, tbl_info_fonctionnaire.date_grade_poste_actuel, CalcAge([date_naissance],Date()) AS CalculateAge, CalcAge([date_premiere_grade_poste],Date()) AS WorkAge, DateAdd("yyyy",60,[date_naissance]) AS After60Y, DateAdd("m",18,[date_premiere_grade_poste]) AS After18M FROM tbl_info_fonctionnaire; النتيجة المرفق BASEF.rar

تفضل أخي المرفق عند فتح فورم1 يتم طلبك . sum20-1.rar

عليكم السلام إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا .... Sub test() Dim a, w Dim T As String Dim i& a = Sheets("aaa").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) T = a(i, 2) & a(i, 3) & a(i, 4) If Not .exists(T) Then .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4), a(i, 1), a(i, 1) + IIf(a(i, 1) = 1, 199, 99)) Else w = .Item(T): w(5) = w(4) + 99: .Item(T) = w End If Next Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2) + 2) = Application.Index(.items, 0, 0) End With End Sub

وعليكم السلام ورحمه الله وبركاته تفضل جرب هذا التعديل دفتر اليوميه كمال.علي محمد على.xlsx

بعد إذن أخينا الفاضل محمد هشام هذا الكود بنفس طريقتك Sub ww() Dim sh As Worksheet, i As Double: i = 2 For Each sh In Sheets If sh.Name <> "Sheet1" And sh.Name <> "Sheet2" And sh.Name <> "Sheet3" And sh.Name <> "Sheet7" Then Sheets("Sheet1").Hyperlinks.Add Sheets("Sheet1").Cells(i, 1), "", "'" & sh.Name & "'!a1", sh.Name, sh.Name sh.Hyperlinks.Add sh.Cells(1, 5), "", "'Sheet1'!a1", "Sheet1", "رجوغ" sh.Cells(1, 5).Font.Size = 30: i = i + 1 End If Next MsgBox "Dobe by mr-mas.com" End Sub رغم أني أعتقد كان من السهل على حضرتك عمل التعديل إن كنت حضرتك صاحب الكود أما إن كنت استخدمت كود غيرك فمن الواضح أنك لم تقم بمدارسته وفهمه بالتوفيق

تفضل جرب Sub test() Dim i As Integer i = 2 For Each sh In ThisWorkbook.Worksheets Select Case sh.Name Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet7" '<----- 'تجاهل الاوراق التالية Case Else Application.ScreenUpdating = False ActiveWorkbook.Sheets("Sheet1").Hyperlinks.Add _ Anchor:=ActiveWorkbook.Sheets("Sheet1").Cells(i, 1), _ Address:="", _ SubAddress:="'" & sh.Name & "'!A1", _ TextToDisplay:=sh.Name sh.Hyperlinks.Add Anchor:=sh.Range("E1"), Address:="", SubAddress:="Sheet1" & "!A1", TextToDisplay:="رجوع" sh.Range("E1").Font.Size = 30: sh.Rows(1).AutoFit i = i + 1 End Select Next sh Application.ScreenUpdating = True End Sub ارتباط تشعبي.xlsm

السلام عليكم و رحمة الله و بركاتة برنامج حساب الوزن من تصميمي حساب الوزن.xlsx

عليكم السلام جرب المعادلة في الخلية B2 , اسحب نزولا ويسارا عسى يكون المطلوب =INDEX('1'!$A$1:$AN$74,MATCH($A2,'1'!$A$1:$A$74,0),MATCH($A$1:$AN$1,'1'!$A$1:$AN$1,0)) أو =INDEX('1'!$A$1:$AN$74;MATCH($A2;'1'!$A$1:$A$74;0);MATCH($A$1:$AN$1;'1'!$A$1:$AN$1;0)) حسب الإعدادات لديك تجربة (2).xlsx

وعليكم السلام جرب الكود التالي حيث سيقوم الكود باستخراج القيم الفريدة أي الغير مكررة ويضعها في العمود الرابع Sub Test() Dim d As Object, rng As Range, c As Range Set d = CreateObject("Scripting.Dictionary") Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) For Each c In rng If c.Value <> "" Then d(Val(c.Value)) = Empty Next c Range("D1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys) End Sub

السلام عليكم الملف النهائي . ان شاء الله والحمد لله في المرفق اللهم اجعل هذا العمل خالصا لوجهك الكريم gdarat_ofcina.xlsb

Try this code Sub Test() Dim wk As Worksheet, sh As Worksheet, ws As Worksheet, lr As Long Set wk = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) Set ws = CopyWorksheet(wk.Name, wk.Range("B5").Value) Application.ScreenUpdating = False With sh lr = .Cells(Rows.Count, "J").End(xlUp).Row + 1 .Range("B" & lr).Resize(, 5).Value = wk.Range("B5").Resize(, 5).Value .Range("I" & lr).Resize(, 3).Value = Array(wk.Range("D13").Value, wk.Range("D23").Value, wk.Range("D30").Value) .Range("L" & lr).Formula = "=SUM(I" & lr & ":K" & lr & ")" .Range("N" & lr).Value = wk.Range("F41").Value Application.Goto .Range("A1") End With Application.ScreenUpdating = True End Sub Function CopyWorksheet(ByVal sheetName As String, ByVal newName As String) As Worksheet Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False ThisWorkbook.Worksheets(newName).Delete Application.DisplayAlerts = True On Error GoTo 0 ThisWorkbook.Worksheets(sheetName).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ActiveSheet.Name = newName Set CopyWorksheet = ActiveSheet Application.ScreenUpdating = True End Function

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله لطالما أردت طرح هذا الموضوع الهام جداً والشيق جداً والمفيد جداً .. ولكن يبدو أن الزهايمر يلعب دوراً هاماً في حياتي .. عموماً ذكرني عنوان موضوع رأيته الآن بهذا الموضوع ، فأحببت أن أشارككم هذا الكود الرائع والمتميز .. الكود يقوم بالمهام التالية .. في بداية تنفيذ الكود يمكنك الكود من اختيار الطابعة المطلوب الطباعة عليها .. من خلال الصور سأقوم بالطباعة على ملف بامتداد XPS .. حتى لا أهدر أوراقي (سامحوني .. دا مش بخل دا حرص مش كدا ولا ايه يا فلاحجي (لأنه أكتر واحد هيفهمني )) حسناً رأيتم الصورة معبرة ..أليست كذلك؟ نقرنا على زر الأمر PRINT ...فظهرت نافذة تتيح لنا إمكانية اختيار الطابعة ثم نضغط أوك لننتقل للنافذة التالية في النافذة التالية يتيح الكود كتابة عدد النسخ المراد طباعتها وبشكل افتراضي يكون عدد النسخ نسخة واحدة فقط ، ويمكن تغيير عدد النسخ المطلوبة هنا تظهر لك أوراق العمل الموجودة في المصنف عدا ورقة العمل النشطة المسماة Data ، يمكنك الكود من اختيار أوراق العمل المراد طباعتها بكل سهولة ثم أخيراً يتم تنفيذ أمر الطباعة ..في المثال الموضح سأقوم بتنفيذ أمر الطباعة لملف بامتداد XPS .. حيث يتم كتابة اسم الملف وتحديد المسار الذي سيحفظ فيه الملف ثم اوك قمت بتحديد مسار حفظ الملف بامتداد XPS على سطح المكتب وها هو الملف وقد طبع ورقتي العمل Sheet1 و Sheet3 فقط ، لأنني حددتهما من خلال النوافذ التي تظهر وأخيراً إليكم الكود الرائع الذي يقوم بكل هذه المهام الرائعة Sub PrintSelectedSheets() Dim I As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim Cb As CheckBox Dim Numcop As Long Dim Cnt As Integer Dim X As String Application.Dialogs(xlDialogPrinterSetup).Show Application.ScreenUpdating = False If ActiveWorkbook.ProtectStructure Then MsgBox "المصنف محمي", vbCritical Exit Sub End If Set CurrentSheet = ActiveSheet X = CurrentSheet.Name Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 TopPos = 40 For I = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(I) If Application.CountA(CurrentSheet.Cells) <> 0 And CurrentSheet.Visible Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).Text = CurrentSheet.Name TopPos = TopPos + 13 End If Next I PrintDlg.Buttons.Left = 240 With PrintDlg.DialogFrame .Height = Application.Max(68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "اختر أوراق العمل المراد طباعتها" End With PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront Numcop = Application.InputBox("أدخل عدد النسخ للطباعة:", "كم عدد النسخ?", 1, Type:=1) If Numcop = 0 Then ElseIf Len(Numcop) > 0 Then End If CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount <> 0 Then If PrintDlg.Show Then For Each Cb In PrintDlg.CheckBoxes If Cb.Value = xlOn Then If Cnt = 0 Then Worksheets(Cb.Caption).Select Else Worksheets(Cb.Caption).Select Replace:=False End If Cnt = Cnt + 1 End If Next Cb ActiveWindow.SelectedSheets.PrintOut copies:=Numcop End If Else MsgBox "كل أوراق العمل فارغة", 64 End If Application.DisplayAlerts = False PrintDlg.Delete Sheets(X).Select End Sub تقبلوا جميعاً وافر تقديري واحترامي حمل الملف من هنا تحميلك للملف يدعم صاحب الموضوع .. فلا تبخل بدقيقة من وقتك .. وللعلم يمكنك عدم تحميل الملف ونسخ الكود في موديول في المصنف الخاص بك ، وستجد الكود جاهز للعمل لديك بدون تحميل الملف .. دمتم على طاعة الله ...

السلام عليكم اليوم اضع لكم شرح حل لموضوع تفعيل الماكرو عن طريق لغة برمجة الفيجوال بيسك 6 بداية الشرح اولا سنقوم بعمل مشروع جديد ليظهر معنا فورم واحد وهو المطلوب لكي يتم ربط الاكسيل مع الفيجوال لابد من وجود مرجع يعتمد عليه البرنامج للتعامل مع الاكسيل وهذه صور من دروس سابقة لمعرفة كيفية اضافة مرجع لبرنامج الاكسيل داخل المشروع الخاص بنا صور من درس سابق لربط الفيجوال بالاكسيل بعد ان قمنا باضافة المرجع الخاص بالاكسيل نأتي لمشروعنا دا شكل الفورم وكوده هتضيف صورة او ليبل حسب ما تشوفه مناسب ليك ودا بدون اي اكواد عادي نأتي للكود نضع في الحدث load الكود التالي Private Sub Form_Load() Dim Start, Finsh Form1.Show Start = Timer Finsh = Start + 5 Do Until Finsh <= Timer DoEvents Loop Unload Me Excel.Workbooks.Open App.Path + "\yasser.xlsm" Excel.Application.Visible = True End Sub الكود عبارة عن اعلان عن متغيرين بداية ونهاية البداية تساوي التايمر النهاية تساوي التايمر + اي وقت تضيفه لفترة عرض الفورم كشاشة افتتاحية وبعد كدا ندخل في حلقة تكرارية حتى تكون النهاية اقل من او تساوي الوقت وبعد تحقق الشرط يتم غلق الفورم وفتح ملف الاكسيل وعرضه في الوضع المرئي وبكدا يكون انتهينا من الدرس الكل مستغرب فيين كود تفعيل الماكرو اقوله مفيش ليه اقوله لان تشغيل ملف الاكسيل عن طريق ملف تنفيذي يجبر وحدات الماكرو على العمل حتى وان كانت غير مفعله الفكرة موجودة من زمان بس محدش كان واخد باله منها لاننا كنا بنقوم بربط ملف عادي وليس به اي وحدات ماكرو وطبعا نقوم بتحويل الملف لملف تنفيذي بعد الانتهاء بالنسبة لمن لديه اي صعوبات في التعامل مع الفيجوال6 يتابع الدروس من اولها حتى يتثنى له انهاء هذا العمل اما بخصوص من لديه الرغبة في وضع هذه الشاشة الافتتاحية ولا يريد ان يشغل باله اقوله ايضا سأقوم بعمل ملف به خيارات لضبطه كما تحتاج للردود او الاستفسار يرجى الدخول على هذا الرابط مرفق السورس كود للبرنامج لمن لا يريد وجع دماغه تقبلو تحياتي ياسر العربي يتبع vb6 &vba.rar

السلام عليكم اليوم اضع لكم حل لموضوع تفعيل الماكرو عن طريق لغة برمجة الفيجوال بيسك 6 كثير منا يقوم ببناء برنامجه ولكن تظل مشكلة تفعيل الماكرو العائق امام تشغيل برنامجنا على اجهزة اخرى فيضيع علينا اظهار الانطباع الاول لبرنامجنا واللي ميعرفشي موضوع البرمجة ويلاقيك محتاس عمال تفعل الماكرو كل ما تشغله على جهاز جديد يقول انك مش محترف المهم عشان نشغل برامجنا على اي جهاز بدون تفعيل الماكرو وانسى الماكرو خالص قمت بعمل برنامج بسيط يعمل كواجهه للبرنامج الخاص بنا او كشاشة دخول برنامجنا وتبدأ كما بالصورة لمدة نحددها نحن وبعدها تختفى ويفتح لنا البرنامج بدون تفعيل الماكرو كل ما علينا ان نضع ملف البرنامج الخاص بنا بجانب الملف التنفيذي الذي سيعمل كشاشة بداية للبرنامج ونغير اسم برنامجنا الى ما هو موضح بالصورة Yasser.xlsm وهذا مؤقت فقط لحين شرح كيفية عمل هذه الشاشة الافتتاحية وتحطوا اي اسم لبرنامجكم وطبعا الامتداد xlsm ويمكن تغييره حتى ممكن نلعب في الامتداد ونخليه مثلا Yasser.dat ونخفيه كمان يبقي كأنه بيشغل من البرنامج التنفيذي المهم كل واحد عنده ملف به اكواد ماكرو يقدر يعطل الماكرو عنده ويحط ملفه بجانب هذا الملف التنفيذي ويقوم باعادة التسمية ليصبح Yasser.xlsm ويقولي ايه رأيه مش هشرح غير لما الاقي تفاعل الملف مرفق به طريقتين لعمل الملف التنفيذي تستطيعوا تجربة اي واحد للردود او الاستفسار يرجى الدخول على هذا الرابط تقبلو تحياتي ياسر العربي يتبع start.rar