الـعيدروس

استاذي الحبيب محمد طاهر ليس للقراءة تضيف وتعدل عليه وكأنك على اكسل الوندوز ليس من الضروري ان يكون به مشاركه الملف برنامج الفيديو "ScreenN2EXE" المرفق البرنامج تحياتي وشكري SCREXESetup.rar

السلام عليكم اخي الفاضل office 2003 انشاء مودويل في ملف الوورد والصق به الكود التالي اولاً حدد المسار الذي به ملفات الوورد إن كانت بغير فولدر الملف اول الكود Pth = ThisDocument.Path وإمتداد ملفات الوورد لديك Fr = ".doc" بعد تعديل المعطيات نفذ الكود Public Sub Ali_Wd() Dim Pth$, Fr$ '************************** ' المسار الحالي نفس فولدر الملف Pth = ThisDocument.Path ' أو غيره إلى مسار الذي به ملفات الورد كالتالي 'Pth = "C:\A" '************************** ' إمتداد ملف الوورد الحالي ' غيره حسب امتداد ملفات الوورد لديك Fr = ".doc" Prnt_F Pth, Fr End Sub Private Sub Prnt_F(Pth As String, Frm As String) Dim Nm$, Mr$ Dim Wr As Document On Error Resume Next Mr = ThisDocument.Name Nm = Dir(Pth & "\" & "*" & Frm) Do While Nm <> "" If Not Nm = Mr Then Set Wr = Documents.Open(Pth & "\" & Nm) Wr.ActiveWindow.PrintOut Wr.Close 0 Set Wr = Nothing Nm = Dir End If Loop On Error GoTo 0 End Sub تحياتي

السلام عليكم عن طريق Gmail Drive والمرفق فيديو به التفاصيل 1.rar

السلام عليكم الاستاذ محمد طاهر يوجد الصفحه التفاعليه كأنك بالاكسل بالـ Gmail و الـ SkyDrive أنا اعمل على الـ Gmail وشغال مزبوط والمعادلات برضه

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

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

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

واذا لديك اكثر من جدول بالورقة الواحدة وتريد حذف جداول محددة بالاسامي اضن بيكون كالتالي جرب وابلغنى بالنتائج Public Sub Ali_Tab() Dim Sht As Worksheet Dim Tb As ListObject Dim rnm As Variant Dim r_Tb As Range Anm = Array("الجدول1", "الجدول2", "الجدول3", "الجدول4", "الجدول5", "الجدول6") On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For ii = 0 To UBound(Anm) Set Tb = Sht.ListObjects(Anm(ii)) With Tb Set r_Tb = .Range .Unlist With r_Tb .Interior.ColorIndex = xlColorIndexNone .Font.ColorIndex = xlColorIndexAutomatic .Borders.LineStyle = xlLineStyleNone End With End With Set Tb = Nothing Next ii Next Sht On Error GoTo 0 End Sub وهذا للحذف Public Sub Ali_Tab() Dim Sht As Worksheet Dim Tb As ListObject Dim rnm As Variant Dim r_Tb As Range Anm = Array("الجدول1", "الجدول2", "الجدول3", "الجدول4", "الجدول5", "الجدول6") On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For ii = 0 To UBound(Anm) Set Tb = Sht.ListObjects(Anm(ii)) '********* Tb.Delete '********* Set Tb = Nothing Next ii Next Sht On Error GoTo 0 End Sub تحياتي

وإذا كان حذف الجدول تماماً مع بياناته Public Sub Ali_Tab() Dim Sht As Worksheet Dim Tb As ListObject Dim r_Tb As Range On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For Each Tb In Sht.ListObjects Tb.Delete Next Tb Next Sht On Error GoTo 0 End Sub

السلام عليكم اخي الفاضل اسلام حسب فهمي لطلبك تريد تحويل الجداول الى نطاق وليس حذفهم ؟ إستخدم الكود التالي : Public Sub Ali_Tab() Dim Sht As Worksheet Dim Tb As ListObject Dim r_Tb As Range On Error Resume Next For Each Sht In ThisWorkbook.Worksheets For Each Tb In Sht.ListObjects With Tb Set r_Tb = .Range .Unlist With r_Tb .Interior.ColorIndex = xlColorIndexNone .Font.ColorIndex = xlColorIndexAutomatic .Borders.LineStyle = xlLineStyleNone End With End With Next Tb Next Sht On Error GoTo 0 End Sub

تفضل ان شاء الله تمام بعد التجربه Code Split2.rar

اخي عيد عفوا حمل المرفق مرة اخرى امل ان يعمل معك

جرب التعديل التالي تم تعديل المرفق Code Split2.rar

السلام عليكم الاخ الفاضل عباس السماوي جزاك الله خير وبارك فيك على المرور العطر وكلماتك الطيبه الكود يقوم بفتح الملف وينسخ البيانات ثم يقوم باإغلاق الملف بهذا المرفق تم إضافة لصق التنسيقات تفضل جرب المرفق تقبل تحياتي وشكري New folder_A1.rar

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

السلام عليكم جرب المرفق New folder_A.rar

تأكد من المتغير العام Private MyMov As New ClassMove

في عمود إتجاه التغيير معك 3 معادلات ؟ وفي عمود معدل التغيير معادلتين ؟ شاهد المرفق Profseer_v3.2.rar

بيكون بهذا الشكل مع دمج الاثنين Private Sub UserForm_Activate() Dim r As Integer '**** Mov '**** For r = 1 To 9 Me.Controls("Label" & r).Caption = Sheet1.Cells(1, r).Text rabie_NDcharge Next For r = 1 To 6 Me.Controls("Labe" & r).Caption = Sheet2.Cells(1, r).Text rabie_NDcharge Next rabie_NDcharge MultiPage1.Pages(3).Visible = False Application.EnableCancelKey = xlDisabled Application.Visible = False End Sub

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

السلام عليكم شاهد الشرح بالمرفق شرح_تنسيق.rar

السلام عليكم شاهد المرفق كود من اعمال العلامه عبدالله باقشير ( خبور خير ) Copie de Xl0000053.rar

السلام عليكم غير الإمتداد حسب إمتداد الملفات المراد نسخ أوراقها أول الكود Private Const Mtd As String = "*.xls" ' مسار الملفات Private Const Pth As String = "C:\123" ' الإمتداد Private Const Mtd As String = "*.xls" Sub Copy_Sht() Dim W As Workbook Dim Sht As Worksheet NM = ThisWorkbook.Name Fl_M = Dir(Pth & "\" & Mtd) Do While Fl_M <> "" Workbooks.Open Filename:=Pth & "\" & Fl_M Set W = Workbooks(Fl_M) For Each Sht In W.Worksheets Sht.Copy After:=Workbooks(NM).Sheets(1) Next W.Close 0 Fl_M = Dir Loop End Sub تحياتي

الطريقة كما تفضل الاخ احمد اذا كانت الطريقة يدوياً لابد ان تكون الملفات مفتوحه عن طريق كود يمكن ان يقوم بهذا العمل لإرفاق ملف أولاً قوم بضغطه بأحد برامج الضغط ( Winrar أو Winzip ) ثم ارفقه

السلام عليكم Public Sub Rng_Cn() ' D' المدى حسب ملفك العمود ' غيره حسب العمود المراد تطبيق الشروط عليه Frmt_Cnd "D:D" End Sub Private Function Frmt_Cnd(Rn As String) As Variant Range(Rn).Select On Error Resume Next With Range(Rn) .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""جديد""" .FormatConditions(.FormatConditions.Count).SetFirstPriority With .FormatConditions(1) .Interior.Color = RGB(253, 233, 217) End With ' .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""مستعمل""" .FormatConditions(.FormatConditions.Count).SetFirstPriority With .FormatConditions(1) .Interior.Color = RGB(250, 191, 143) End With ' .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""وارد""" .FormatConditions(.FormatConditions.Count).SetFirstPriority With .FormatConditions(1) .Interior.Color = RGB(196, 215, 155) End With ' .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""صادر""" .FormatConditions(.FormatConditions.Count).SetFirstPriority With .FormatConditions(1) .Interior.Color = RGB(149, 179, 215) End With On Error GoTo 0 End With End Function