عبدالله باقشير

السلام عليكم معا ان شاء الله و كل عام وانتم بخير في شي ناقص عندي في مكتبة الاكواد لا يعمل الكود عندي اريد منك التالي من نافذة الاكواد من القائمة ادوات tools اضغط references هذه صورة توضح الخطوات سيظهر لك فورم اضغط زر تصوير الشاشة من الكيبورت والصق الصورة في الرسام وحملها هي مثل الصوره هذه منتظرك

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

السلام عليكم اخي يوسف هل يعمل الكود عندك على اكسل 2003 عندي يطلع رسالة خطأ

السلام عليكم هذا الكود ما نفعش معاك Sub Mail_workbook_1() 'Working in 97-2007 Dim wb As Workbook Set wb = ActiveWorkbook If Val(Application.Version) >= 12 Then If wb.FileFormat = 51 And wb.HasVBProject = True Then MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _ "Save the file first as xlsm and then try the macro again.", vbInformation Exit Sub End If End If On Error Resume Next wb.SendMail "", _ "This is the Subject line" On Error GoTo 0 End Sub وهو منقول من ملف عندي خاص بارسال ايميل فيه نفس الكود الذي تريد تعديله المرفق 2003 SendMail(Attachment)Testers.rar

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

اخي يوسف هل هذا ما قصدته Option Explicit Const mBr As String = "MySheetList" Sub kh_AddName() Dim Nam As Range Dim i As Integer Dim NamSheet As String ''''''''''''''''''''''''''''''' On Error GoTo kh_Err ''''''''''''''''''''''''''''''' kh_BarDelete ''''''''''''''''''''''''''''''' Set Nam = ورقة1.Range("C3:D22") ''''''''''''''''''''''''''''''' With Application.CommandBars.Add(Name:=mBr, Position:=msoBarPopup) For i = 1 To Nam.Rows.Count NamSheet = Nam.Cells(i, "A") With .Controls.Add(Type:=msoControlButton) .Caption = Nam.Cells(i, "B") .OnAction = "GO_MySheet" .Tag = NamSheet If NamSheet = ActiveSheet.Name Then .State = -1 If IsError(Evaluate("'" & NamSheet & "'!A1")) Then .Enabled = False End If End With Next End With ''''''''''''''''''''''''''''''' Application.CommandBars(mBr).ShowPopup ''''''''''''''''''''''''''''''' kh_Err: Set Nam = Nothing If Err Then MsgBox "Err.Number : " & Err.Number kh_BarDelete End Sub Sub kh_BarDelete() On Error Resume Next Application.CommandBars(mBr).Delete On Error GoTo 0 End Sub Sub GO_MySheet() Dim N As String N = Application.CommandBars.ActionControl.Tag Sheets(N).Activate End Sub المرفق 2003-2007 مثال اضافة اسم مخصص لاوراق العمل في بار مخصص.rar

السلام عليكم ايضا هذا السطر يعطيك مسار سطح المكتب MsgBox Environ("USERPROFILE") & "\Desktop"

وعليكم السلام هذا من اصلكم الكريم اكرمكم الله وحفظكم من كل مكروه وعيدكم مبارك وكل عام وانتم بخير تقبل تحياتي وشكري

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

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

جزاكم الله خيرا ملاحظة : تم اختصار الاكواد في المشاركات اعلاه

السلام عليكم حفظ نسخة من الملف على سطح المكتب وحفظ المصنف الاصل بدون اغلاقه Sub kh_SaveCopyInDesktop() Dim wo As Workbook Dim StrDeskPath As String, sPath As String ''''''''''''''''''' StrDeskPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") sPath = StrDeskPath & Application.PathSeparator & ThisWorkbook.Name ' '''''''''''''''''''' With ThisWorkbook .SaveCopyAs sPath .Save End With ' '''''''''''''''''''' End Sub

السلام عليكم حفظ نسخة من الملف على سطح المكتب وحفظ واغلاق المصنف الاصل Sub kh_SaveCopyInDesktop() Dim wo As Workbook Dim StrDeskPath As String, sPath As String ''''''''''''''''''' StrDeskPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") sPath = StrDeskPath & Application.PathSeparator & ThisWorkbook.Name ' '''''''''''''''''''' With ThisWorkbook .SaveCopyAs sPath .Close True End With ' '''''''''''''''''''' End Sub

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

السلام عليكم المعادلة ادريس تعطيك عنوان خلية معينة في شيت معين ADDRESS(1;1;;;B$2) نتيجتها access!$A$1 عبارة عن نص نقوم بتحويله الى مرجع بدالة INDIRECT علشان نستخدمه داخل الدالة OFFSET إرجاع مرجع إلى نطاق عبارة عن رقم معين من الصفوف والأعمدة من خلية أو نطاق خلايا. من الممكن أن يكون المرجع الذي يتم إرجاعه عبارة عن خلية مفردة أو نطاق من الخلايا، يمكنك تحديد عدد الصفوف وعدد الأعمدة التي سيتم إرجاعها. بناء الجملة OFFSET(reference,rows,cols,height,width) Reference (المرجع) المرجع الذي تريد أن تستند إليه الإزاحة. يجب أن يكون المرجع مرجعاً هذا المرجع الذي استخدمناه INDIRECT(ADDRESS(1;1;;;B$2)) والذي يعطي الخلية access!$A$1 Height (الارتفاع) الارتفاع، في عدد الصفوف، الذي تريده للمرجع الذي يتم إرجاعه. يجب أن تكون Height رقماً موجباً. استخدمنا العدد 1000 يعني 1000 صف Width (العرض) العرض، في عدد الأعمدة، الذي تريده للمرجع الذي يتم إرجاعه. يجب أن تكون Width رقماً موجباً. استخدمنا العدد 1 يعني عمود واحد نتيجة المعادلة النطاق a1:a1000 من الورقة access ان شاء الله وصلت المعلومة

الحق اسم الورقة بالنطاق مثلا:/ Sheets("1").Range("B3:H3")

السلام عليكم تفضل الكود التالي: Sub Macro1() Application.ScreenUpdating = False Sheets("1").Range("D3:D17").Copy Range("D3") Application.ScreenUpdating = True End Sub وكرر الكود مع تغيير اسم الورقة

السلام عليكم ضع الكود من ضمن اكواد الفورم Private Sub UserForm_Initialize() Me.ComboBox1.Column = Range("B3:H3").Value Me.ComboBox2.Column = Range("B4:H4").Value End Sub

السلام عليكم فكرة رائعة اخي الحبيب الخالدي--------حفظكم الله وتطوير ذكي اخي عباد -------------حفظكم الله تقبلوا تحياتي و شكري

لو بامكانك تغيير مكان الجدول الاسفل احسن او استخدم الفرز للجدول الاعلى

السلام عليكم بدلا من المسح استخدم حذف خلايا Target.Resize(1, 4).delete xlUp يحذف الخلايا المعينة فقط بازاحة الخلايا السفلية الى اعلى بدون المساس ببقية خلايا الصف

السلام عليكم شاهد المرفق 2003-2007 بحث واضافة2.rar

السلام عليكم جزاكم الله خيرا تقبل تحياتي وشكري

السلام عليكم استبدل اكواد الفورم بهذه Private Sub ComboBox1_Click() Dim i As Long i = Me.ComboBox1.ListIndex + 16 With Sheets("1") TextBox1 = .Cells(i, 2) TextBox2 = .Cells(i, 5) TextBox3 = .Cells(i, 6) TextBox4 = .Cells(i, 7) TextBox5 = .Cells(i, 8) TextBox6 = .Cells(i, 9) End With End Sub Private Sub UserForm_Activate() Dim Last As Long Last = Sheets("1").Range("B10000").End(xlUp).Row Me.ComboBox1.List = Sheets("1").Range("B16:B" & Last).Value End Sub

السلام عليكم الشكر واصل للاخ ابو انس حفظه الله كود التنقل يكفي سطر واحد ' كود التنقل بين الاوراق Sub ShowSheetLists() Application.CommandBars("Workbook tabs").ShowPopup End Sub وطلب صاحب الموضوع في المرفق ادناه ------------------------------------- فكرة الكود : ان زر التنقل موجود في الورقة الرئيسية والكود اثناء اضافة الورقة الجديدة ينسخ الزر ويلصقه في هذه الورقة ------------------------------------- المرفق 2003-2007 زر للتنقل.rar