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

وعليكم السلام -يمكنك استخدام هذه المعادلة =IFERROR(INDEX(ورقة1!B2:B270,MATCH(0,COUNTIF($A$1:A1,ورقة1!B2:B270),0)),"") تلخيص1.xlsx

اليك حل اخر Sub CopyData() Dim x, y(), i&, lr&, ws_rng2&, ws_rng3& Set ws_rng = Sheet1 lr = ws_rng.Range("A" & Rows.Count).End(xlUp).Row x = ws_rng.Range("A2:B" & lr) For i = 1 To UBound(x, 1) If x(i, 2) <> 0 Then ws_rng3 = ws_rng3 + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ws_rng3) For ws_rng2 = 1 To UBound(x, 2) y(ws_rng2, ws_rng3) = x(i, ws_rng2) Next End If Next ws_rng.Range("k2").Resize(ws_rng3, UBound(y, 1)) = Application.Transpose(y) End Sub آسف لم انتبه لمسألة تعدد أوراق العمل لعدم وجودها على الملف المرفق سوف أقوم باظافتها لاحقا. فقط لاثراء الموضوع لا أكثر.فحل الأستاذ @محي الدين ابو البشر يوفي بالغرض ورقة عمل جديد.xlsm

مثال : احمد محمد محمود حامد > يمكنك البحث عن ( محمد محمود ) لكن لا يمكن البحث عن ( احمد حامد ) السلام عليكم اعتقد استاذي @محمد ايمن يمكن البحث عن احمد حامد بكتابة ( احمد*حامد) فانها تظهر عند الفلترة

عليكم السلام ورحمة الله وبركاته ما رأيك بكود Sub test() Dim a Dim i&, ii& Dim sh As Worksheet For Each sh In Worksheets ii = 1 a = sh.Cells(1).CurrentRegion ReDim b(1 To UBound(a), 1 To UBound(a, 2)) For i = 2 To UBound(a) If a(i, 2) <> "" Then b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2) ii = ii + 1 End If Next sh.Cells(2, 11).Resize(ii, 2) = b Next End Sub ورقة عمل Microsoft Excel جديد (2).xlsm

بالنسبة لي سأساهم في هذا الجزء بدالة تقوم بتوحيد الحروف المتشابهة إلى حرف واحد وذلك لتلافي موضوع أخطاء الطباعة : 🙂 Function ReplaceArabicLetters(strText As String) As String ' استبدال الحروف العربية المتشابهة إلى حرف واحد وذلك لاستخدامها في عملية البحث وتلافي أخطاء الكتابة ' أ،إ،ا =(تحول إلى)=> ا ' ي،ى =(تحول إلى)=> ي ' ـه،ـة =(تحول إلى)=> ـه ' Moosak strText = Replace(strText, "أ", "ا") strText = Replace(strText, "إ", "ا") strText = Replace(strText, "ى", "ي") strText = Replace(strText, "ة", "ه") ReplaceArabicLetters = strText End Function مثال : ReplaceArabicLetters("أجمل إنسان في الحياة من ينسى الأحزان ويعيش الأمل") النتيجة : اجمل انسان في الحياه من ينسي الاحزان ويعيش الامل

تفضل اخي الكريم Book1.xlsm

حسب الصورة عسى Sub Test() Dim i& For i = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(i, 1).Interior.Color = vbYellow Then Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Cells(i, 1).Value Next End Sub Book1.xlsm

@محمد القدسي كلامك صحيح اخي الكريم وهذا تعديل للمثال بحث بعدد 3الكلمات.rar

اخي الكريم @حامل المسك السلام عليكم و رحمة الله و بركاته حسب خبرتي ( والله اعلم ) لا يمكنك البحث ضمن الحقل الواحد بهذه الطريقة أي انه يمكنك البحث عن كلمة واحدة فقط ( او نص متسلسل ) ليرجع لك كافة السجلات التي تحتوي تلك الكلمة مثال : احمد محمد محمود حامد > يمكنك البحث عن ( محمد محمود ) لكن لا يمكن البحث عن ( احمد حامد ) تم حل مشكلة تجاهل الهمزات و التاء بفضل مساعدة اخينا @Moosak بحث بعدد 2الكلمات.rar

تفضل هذا التعديل تفعيل وايقاف اضافة سجل للمكرر.mdb

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

عليكم السلام البرنامج يرى المربعات كنص وليس رقم استخدم الدالة int قبل كل حقل مثال : int([text1])+int([text2])

تفضل اخي الكريم مبدئيا تم حل الطلب الأول 😅 بحث بعدد الكلمات.rar

بالفعل نحن نستخدم استعلام الحاق .. ونستدعيه بالدالة RunSQL DoCmd.RunSQL "INSERT INTO customer_account_sub ( Date1, Invoice_No, Invoice_Value ) " & vbCrLf & _ "SELECT Sales_Invoice_main_AHMED_profits.sales_Invoice_date, Sales_Invoice_main_AHMED_profits.Sales_Invoice_No, Sales_Invoice_main_AHMED_profits.net_sell_after_vat " & vbCrLf & _ "FROM Sales_Invoice_main_AHMED_profits " & vbCrLf & _ "WHERE (((Sales_Invoice_main_AHMED_profits.sales_Invoice_date) Between [Forms]![AHMED_account_$]![customer_account_main_Query_AHMED_dollar]![Date3_from] And [Forms]![AHMED_account_$]![customer_account_main_Query_AHMED_dollar]![Date3_To]))" فلو قمنا بنسخ هذا ولصقه في استعلام فارغ .. وازلنا عنه بعض العبارات الزائدة مثل " & vbCrLf & _ وكذلك ازلنا الامر DoCmd.RunSQL في اول الجملة وايضا علامات التنصيص لحصلنا على استعلام الحاق الذي نحن نعرفه .

إن شاء الله تكون الأخيرة 🙂 نصيحة: إذا صادف وجود عطلة نهاية الأسبوع (Weekends) وسط عطلة رسمية Holiday، لا تحاول تقسيم العطلة لأن عطلة نهاية الأسبوع هي جزء من العطلة الرسمية، والبرنامج سوف يهتم بهذه الجزئية في الحسابات. WM2000_06.mdb

استبدل هذا Sub gmgm1() Worksheets("تسجيل البيعة").Range("c4:i16").SpecialCells(2, 3) = ClearContents End Sub بدل Sub gmgm1() Worksheets("تسجيل البيعة").Range("c4:i16") = ClearContents End Sub

أهلا بك.. يمكن استخدام الشفرة التالية في حدث النموذج KeyDown Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Static I As Integer, PgCnt As Integer PgCnt = Me.MyTabs.Pages.Count - 1 Select Case KeyCode Case Is = 34 If I <= 0 Then Me.MyTabs = 0 Else I = I - 1 Me.MyTabs = I End If Case Is = 33 If I >= PgCnt Then Me.MyTabs = PgCnt Else I = I + 1 Me.MyTabs = I End If End Select Debug.Print KeyCode End Sub TabCtrlNav.zip

تفضل جرب Private Sub TextBox26_Change() Dim CelF As Range, LigF As Long Set ws = ActiveWorkbook.Sheets("Data") With ws Set lst = ws.ListObjects("الجدول1") If lst.ShowAutoFilter Then lst.ShowAutoFilter = False End If Set CelF = ws.Range("Find").Find(What:=Me.TextBox26, LookIn:=xlValues, LookAt:=xlWhole, _ SearchDirection:=xlNext, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not CelF Is Nothing Then LigF = CelF.Row Label1.Caption = ws.Range("B" & LigF) Label2.Caption = ws.Range("C" & LigF) Label3.Caption = ws.Range("E" & LigF) Label4.Caption = ws.Range("D" & LigF) Else For S = 1 To 3 Me("Label" & S) = Empty Next S End If End With Label2 = Format(Label2, "dd/mm/yyyy") Label2.BackColor = &H8000000F End Sub TEST V1.xlsb

وعليكم السلام-ياريت تقوم بتغيير عنوان المشاركة ليصبح ( معادلة IF متعددة الشروط) وهذه المعادلة تفى بالغرض وشكراً =IF(AND($C4<>"غ",$B4="ذكر"),"ناجح",IF(AND($C4<>"غ",$B4="أنثي"),"ناجحة",IF(AND($C4="غ",$B4="ذكر"),"ناجح بحكم القانون",IF(AND($C4="غ",$B4="أنثي"),"ناجحة بحكم القانون","")))) معادلة IF.xlsx

خطأ لأنك تحتاجها في عميليات اخرى ... مثل الجرد نقل عهده ... الخ ..

جرب المرفق .. تمت كتابة المعادلة بواسطة الذكاء الاصطناعي 🙂 الوقت.xls

السلام عليكم تفضل الحل You must remove filters from your data to be able to drag and increase numbers. It is possible to do this in a few ways. Firstly, select the tiny Filter icon in cell B4 and choose Clear Filters From “Names” and hit the OK button. Or, you can select Sort & Filter >> Filter from the Home tab. Besides clicking on the Filter icon from the Data tab gives the same result. Alternatively, you can use CTRL+SHIFT+L as a keyboard shortcut. But the last three ways completely remove all filters from the worksheet. محرك بحث ديناميكي.xlsm

السلام عليكم و رحمة الله هذه الجزئية فى الكود السابق من شأنها مسح البيانات السابقة قبل ترحيل الفصل المطلوب ws.Range("C9:H100")="" اعد نسخ الكود مرة اخرى و سوف تراها

السلام عليكم و رحمة الله استخدم هذا الكود Sub ColData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long Dim Arr As Variant, C As Range Dim p As Long, FSL As String Set ws = Sheets("مجمع") ws.Range("C9:H100")="" FSL = ws.Range("S4") 1 '----------------- On Error Resume Next For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3")) LR = Sh.Range("O" & Rows.Count).End(3).Row i = i + LR Next 2 '----------------- ReDim Arr(i, 6) p = 0 For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3")) For Each C In Sh.Range("O10:O" & LR) If C.Value = FSL Then Arr(p, 0) = p + 1 Arr(p, 1) = C.Offset(0, -10).Value Arr(p, 2) = C.Offset(0, -6).Value Arr(p, 3) = C.Offset(0, -4).Value Arr(p, 4) = C.Value Arr(p, 5) = C.Offset(0, 1).Value p = p + 1 End If Next Next 3 '----------------- If p > 0 Then ws.Range("C9").Resize(p, 6).Value = Arr 4 '----------------- End Sub

اخي طارق نادر جرب المرفق تحويل معادلة إلى كود.xlsm

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

أخبرتكم أن النسخة السابقة هي الأخيرة ولكن سيطرت علي فكرة في الوصول إلى تاريخ أم القرى بدون فرق ، وقد نجحت الفكرة والحمد لله. سأطبقها إن شاء على مثال للأكسس الحقوق الفكرية محفوظة 🙂 كشف انتهاء هويات الموظفين_05.xlsm

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

تفضل حبيبي الحل تجربة2.rar

و هنا ترجمة التعليقات الواردة في الكود : ' في كود ThisWorkBook 'Macro Créée par : BigFish (Philippe E) 'le :06-11-2008 'Mis à jour le : 03/09/2010 'V1.3 ' Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Cancel = True HideSheets WBkSave (SaveAsUI) End Sub Private Sub Workbook_Open() Dim CmdBs As CommandBar ' إذا تم تفعيل الماكروات سيتم إظهار الشيتات المخفية ' و في حالة العكس تبقى مخفية و تظهر رسالة خطأ ' تركت هذا الخيار الذي يشتغل إذا كان الملف لم يحفظ مع ' خيار IsAddin is True . في حالة العكس لا يعني الأمر شيئا . Application.Run ("Opening") ‘ تعطيل شريط نافذة أدوات كونترول For Each CmdBs In Application.CommandBars Select Case CmdBs.Name Case "Control Toolbox", "Boîte à outils Contrôles" 'cas Anglais ou Français CmdBs.Enabled = False End Select Next ' تهيئة الفصل / القسم Set XlAppli.XL = Excel.Application Call XlAppli.InitClass ' منع استخدام اختصارات لوحة المفاتيح Alt+F11 و Alt+F8 Application.OnKey "%{F11}", "MessageDeLimitation" Application.OnKey "%{F8}", "MessageDeLimitation" DoEvents ' هذا الملف تم حفظه مع خيار IsAddin is True إذن يتم تحويله إلى False ‘ لإعادة إعطائه كل وظائف Workbook التقليدية If ThisWorkbook.IsAddin = True Then ThisWorkbook.IsAddin = False 'إذا كان VBE مفتوحا يتم إغلاقه و لكن ليشتغل الأمر يجب أن يكون خيار الأمان " الثقة في مشروع فيجوال بيسك " مؤشرا عليه . On Error Resume Next If Application.VBE.MainWindow.Visible = True Then Application.VBE.MainWindow.Visible = False MyFileIsOpen = True End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) ' البعض مما سيأتي لاحقا لا يصلح إلا لإدارة مرور IsAddin = True لهذا الملف في حالة كان المستخدم يرغب في التحفيظ قبل الإغلاق . ' لهذا سيتم استبدال رسالة الإكسل برسالتنا الشخصية مما يسمح بإدارة حالة الزر "إلغاء" If MyFileIsOpen = True Then Exit Sub Dim Reponse As VbMsgBoxResult If ThisWorkbook.Saved = True Then ' عودة إلى الإفتراضي العادي Defaut ' يتم إفراغ القسم/ الفصل Call XlAppli.EmptyClass Else Cancel = True ' هنا رسالتنا الشخصية On Error Resume Next Reponse = MsgBox("Do you want to save the changes made in '" & ActiveWorkbook.Name & "' ? ", vbExclamation + vbYesNoCancel) Select Case Reponse Case vbYes 'l'utilisateur veut sauver avant de fermer le fichier HideSheets Application.EnableEvents = False 'pour eviter de passer par l'evenement Workbook_BeforeSave ThisWorkbook.IsAddin = True ThisWorkbook.Save ThisWorkbook.Saved = True Application.EnableEvents = True Application.DisplayAlerts = True Application.ScreenUpdating = True Cancel = False Case vbNo 'l'utilisateur ne veut pas sauver. Pour cela: ' عودة إلى الإفتراضي العادي Defaut ' يتم إفراغ القسم / الفصل Call XlAppli.EmptyClass ' يتم إيهام الإكسل أن الملف تم حفظه ThisWorkbook.Saved = True نسمح بالإغلاق Cancel = False End Select ' في حالة "إلغاء" لا يتم تنفيذ أي شيء End If End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- ' في الموديل المسمى module1 'Macro Créée par : BigFish (Philippe E) 'le :15-11-2008 'Mis à jour le : 03/09/2010 'V1.4 ' Option Explicit Public XlAppli As New ClasseAppli, MyFileIsOpen As Boolean Sub Defaut() Dim CmdBtn As Office.CommandBarButton, CmdBs As CommandBar إعادة استعمال اختصارات لوحة المفاتيح Alt+F11 و Alt+F8 Application.OnKey "%{F11}" Application.OnKey "%{F8}" تفعيل شريط صندوق أدوات الكونترول For Each CmdBs In Application.CommandBars Select Case CmdBs.Name Case "Control Toolbox", "Boîte à outils Contrôles" CmdBs.Enabled = True End Select Next End Sub Sub viderclass() Call XlAppli.EmptyClass End Sub Sub HideSheets() ' إخفاء كل الشيتات باستثناء شيت starting notice ' ' تركت هذا الخيار الذي يشتغل إذا كان الملف لم يحفظ مع Dim MySheet As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False If Sheets("starting notice").Visible = xlVeryHidden Then Sheets("starting notice").Visible = True For Each MySheet In ThisWorkbook.Worksheets If Not MySheet.Name = "starting notice" Then MySheet.Visible = xlVeryHidden End If Next End Sub Sub Opening() Dim MySheet As Worksheet ' إخفاء كل الشيتات باستثناء شيت starting notice Application.ScreenUpdating = False Application.DisplayAlerts = False ThisWorkbook.IsAddin = False For Each MySheet In ThisWorkbook.Worksheets If Not MySheet.Name = "starting notice" Then MySheet.Visible = True End If Next If Sheets("starting notice").Visible = True Then Sheets("starting notice").Visible = xlVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True ThisWorkbook.Saved = True End Sub Sub WBkSave(ByVal SaveAsUI As Boolean) ' هنا يتم الأخذ بعين الإعتبار التحفيظات للتمكن من إدارة خيار IsAddin Dim FileSaveName As String, Reponse As VbMsgBoxResult Application.DisplayAlerts = False Application.EnableEvents = False If SaveAsUI = False Then 'sauvegarde direct ThisWorkbook.IsAddin = True ThisWorkbook.Save Else 'sauver sous FileSaveName = Application.GetSaveAsFilename(ThisWorkbook.Name) If Not FileSaveName = "False" Then 'si l'utilisateur n'a pas utilisé le bouton Cancel If Not Dir(FileSaveName) = "" Then 'si le fichier existe deja Reponse = MsgBox("le fichier '" & Dir(FileSaveName) & "' existe déjà. voulez-vous remplacer le fichier existant ? ", vbExclamation + vbYesNo) If Reponse = vbYes Then ThisWorkbook.IsAddin = True ThisWorkbook.SaveAs Filename:=FileSaveName, AddToMru:=True End If Else 'si le fichier n'existe pas ThisWorkbook.IsAddin = True ThisWorkbook.SaveAs Filename:=FileSaveName, AddToMru:=True End If End If End If Application.EnableEvents = True DoEvents 'on donne les moyens a excel de faire la sauvegarde avant de passer a la suite Opening End Sub Sub MessageDeLimitation() MsgBox "Vos droits sur ce fichier ne vous permettent pas d'acceder à ces fonctions !", vbExclamation End Sub Sub ClosingThisFile() MyFileIsOpen = False ThisWorkbook.Close End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- ' في الموديل الفصل / القسم المسمى ClasseAppli 'Macro Créée par : BigFish (Philippe E) 'Macro Créée par : BigFish (Philippe E) 'le :15-11-2008 'Mis à jour le : 03/09/2010 'V1.2 ' Option Explicit Public WithEvents XL As Excel.Application Dim ClassCmdBrBtn() As ClasseCommandeBarBouton, NbButton As Integer ' السماح بإفراغ الفصل / القسم Public Sub EmptyClass() Dim i As Integer For i = 1 To NbButton On Error Resume Next Set ClassCmdBrBtn(i).BoutonBarre = Nothing Next End Sub ' تعبئة الفصل / القسم Public Sub InitClass() Dim i As Integer, MyCmdBar As CommandBar NbButton = Application.CommandBars("Visual Basic").Controls.Count ' يتم تحديد عدد الأزرار و يتم تحجيم صفيف الجدول the array variable ReDim Preserve ClassCmdBrBtn(NbButton) ' يضاف إلى الفصل / القسم أزرار شريط الفيجوال بيسك For i = 1 To NbButton Set ClassCmdBrBtn(i) = New ClasseCommandeBarBouton Set ClassCmdBrBtn(i).BoutonBarre = Application.CommandBars("Visual Basic").Controls(i) Next End Sub Private Sub XL_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) ' منع إغلاق هذا الملف أو الإكسل مادام مفتوحا If Wb.Name = ThisWorkbook.Name And MyFileIsOpen = True Then Cancel = True End If End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- ' في موديل الفصل / القسم المسمى ClasseCommandeBarBouton 'Macro Créée par : BigFish (Philippe E) 'le :05-11-2008 'V1.1 ' Option Explicit Public WithEvents BoutonBarre As office.CommandBarButton Private Sub BoutonBarre_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean) Select Case Ctrl.Caption Case "&Design Mode", "&Visual Basic Editor", "Control T&oolbox", "&Record New Macro...", "&Macros..." CancelDefault = True Action ' النسخة الإنجليزية إلى حدود XI2003 Case "Nouv&elle macro...", "&Visual Basic Editor", "&Boîte à outils Contrôles", "Mode &Création" CancelDefault = True Action ' النسخة الفرنسية بداية من XI2007 Case "Mo&de Création" CancelDefault = True Action End Select End Sub Sub Action() MsgBox "Vos droits sur ce fichier ne vous permettent pas d'acceder à ces fonctions !", vbExclamation End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- 'في كود الورقة "Sheet1" 'Macro Créée par : BigFish (Philippe E) 'le 03/09/2010 'V1.0 ' ' زر "أغلق هذا الملف" للشيت "Sheet1" Private Sub CommandButton1_Click() ClosingThisFile End Sub

السلام عليكم ورحمة الله وبركاتة منذ فترة قدمت لكم كيفية الحصول على سريال نمبر الهارد ديسك الحقيقى الذى لا يتغير ععند عمل فورمات للهارد ديسك وكان معه ملف مساعد لابد من نسخة الى ملفات النظام يدويا كان على هذا الرابط لمن اراد الاطلاع على بداية الموضوع : سريال نمبر الهارد ديسك الحقيقى الذى لا يتغير عند عمل فورمات ومنذ بضعة ايام اعترض احد الاخوة على انه عند عمل الفورمات يكون الملف المساعد قد تم ازالته رغم علمنا انه عند عمل الفورمات نقوم بنركيب برامجنا التى نعمل عليها فلا يجوز ان نحاول تشغيل ملف اكسيل بدون تركيب برنامج الاكسيل من جديد بعد الفورمات ولكنى وجدت انها فكرة جيده ان يكون استخراج السريال نمر يتضمن نسخ الملف المساعد اتوماتيكيا بدون تدخل وكان هذا البرنامج المرفق عبارة عن ملف هو نفس الملف الموجود بالرابط اعلاه ولكن يقوم بنسخ الملف الساعد ( DLL ) اتوماتيكيا Omar_1.rar

اخي أبو جودي للأسف لم تضبط معي