الـعيدروس

السلام عليكم إستبدل كود إظهار الفورم بهذا Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long Public Sub M_AC(Handle As Long) Dim L_N As Long L_N = SetForegroundWindow(Handle) End Sub Sub data11() UserForm1.Show vbModeless M_AC Application.hwnd End Sub سيصبح التنقل بين الخلايا متاح في حال الفورم مفتوح

السلام عليكم Sub Un_Hide_All() On Error Resume Next Dim sh As Worksheet For Each sh In Worksheets If sh.Name = Sheet4.Name Then GoTo 0 sh.Visible = True ' TRUE = إظهار ' FALSE = إخفاء 0 Next Sheets("GO TO").Select End Sub

السلام عليكم الاخ الفاضل رجب بالامكان إختصار الماكرو لديك بهذا الكود Sub ragab() E = 4 For C = 1 To 8 For R = 2 To Cells(Rows.Count, C).End(xlUp).Row If Cells(R, C).Value <> Empty Then Cells(E, 13) = Cells(R, C) E = E + 1 End If Next Next End Sub

جرب هكذا Sub XX() On Error Resume Next Application.EnableEvents = False Sheets(1).Range("IT1").Value = 1 Application.DisplayFormulaBar = False With ThisWorkbook .Save End With Application.Quit Application.EnableEvents = True End Sub

السلام عليكم إضافة بسيطه للكود الاخير جرب بعد التعديل ان شاء الله يزبط معاك Sub XX() On Error Resume Next Application.EnableEvents = False Sheets(1).Range("IT1").Value = 1 With ThisWorkbook .Save .Close End With ' Application.Quit Application.EnableEvents = True End Sub

السلام عليكم الاخ طاهر تفضل المرفق وبه الأكواد C_SHOW_A.rar

السلام عليكم جزاك الله خير استاذ عبدالله دائما نتعلم منكم وهذه حيلة بسيطه زبطت معي هذه اكواد حدث THISWORKBOOK Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next If Sheets(1).Range("IT1").Value = 0 Then Cancel = True Else Cancel = False End If End Sub Private Sub Workbook_Open() Sheets(1).Range("IT1").Value = 0 ActiveWindow.DisplayHeadings = False Application.DisplayFormulaBar = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)" End Sub وهذا الكود الإغلاق Sub XX() On Error Resume Next Application.EnableEvents = False Sheets(1).Range("IT1").Value = 1 With ThisWorkbook .Save End With Application.Quit Application.EnableEvents = True End Sub

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

السلام عليكم تفضل هذا الكود لتقييد الرجوع Full screen Sub ALI_CANCEL() ActiveWindow.DisplayHeadings = False Application.DisplayFormulaBar = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)" End Sub وهكذا للرجوع للوضع العادي Sub ALI_SHOW() ActiveWindow.DisplayHeadings = True Application.DisplayFormulaBar = True Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",TRUE)" End Sub وهذا الكود حطه في حدث THISWORKBOOK لمنع الإغلاق من زر الإكسل Private Sub Workbook_BeforeClose(Cancel As Boolean) Cancel = True End Sub والسلام عليكم

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

السلام عليكم الاخ الفاضل العام الجديد 2012 اضف هذه الجملة في أول الكود ON ERROR RESUME NEXT يصير الكود كالتالي Sub ScreenResolution() On Error Resume Next Dim Zoom& If DisplayVideoResolution = "1024 x 768" Then Zoom = 170 If DisplayVideoResolution = "800 x 600" Then Zoom = 136 If DisplayVideoResolution = "640 x 480" Then Zoom = 85 Sheets("الادخال").Activate ActiveWindow.Zoom = Zoom End Sub

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

السلام عليكم بعد اذن اخي الحبيب konafa4000 هذا شرح على عجله Sub TRHILL() ' عند وجود خطاء اخرج منه On Error Resume Next ' تحديث الشاشة Application.ScreenUpdating = False ' هنا حلقة تكراريةعدد الصفوف إبتداء من الصف الخامس الى الصف الـ 14 فقط 1 For R = 5 To 14 ' متغير لحفظ قيمة قيمة الحلقة لعمود A 2 TS = Cells(R, 1).Value ' حلقة تكرارية من أول ورقة إلى اخر ورقة في المصنف 3 For S = 1 To Sheets.Count ' شرط اذا إسم الورقة تساوي المتغير 4 If Sheets(S).Name = TS Then ' متغير لحفظ إسم ورقة5 5 sh5n = Sheets("Sheet5").Name ' متغير لحفظ اخر سطر فيه بيانات في الورقة التي تساوي الشرط في السطر الرابع 6 ER = Sheets(TS).Range("D1211").End(xlUp).Row + 1 ' متغير لحفظ اخر خليه فيها بيانات في الورقة الخامسه + سطر واحد 7 E5 = Sheets("Sheet5").Range("B1211").End(xlUp).Row + 1 ' متغير لحفظ الأعمدة التي سيتم نسخها 8 RN = "B" & R & ":G" & R ' متغير لحفظ عملية النسخ التالي والتي هيا لعمودين الدائن والمدين 9 RN2 = "B" & R & ":c" & R ' مدين او دائن ' متغير لعملية النسخ الثالثه 10 RN3 = "D" & R & ":G" & R ' نسخ بيانات متغير RN 'Sheets(TS) 11 Range(RN).Copy ' لصقها في الورقة التي حققت الشرط 'Cells(ER, 4). 'ER ' الصف الاخير + سطر الذي في سطر رقم 6 ' 4 ' رقم العمود الذي يعتبر الـ D 12 Sheets(TS).Cells(ER, 4).PasteSpecial Paste:=xlPasteValues ' نسخر بيانات متغير RN2 13 Range(RN2).Copy ' لصقها في الورقة التي في متغير سطر 5 'Sheets(sh5n) = التي هيا sheet5 'Cells(E5, 2) 'E5 ' لصق في صف متغير سطر 7 '2 ' عمود رقم2 الذي هو B 14 Sheets(sh5n).Cells(E5, 2).PasteSpecial Paste:=xlPasteValues ' sheet5 ' اخر سطر فيه بيانات السطر الذي يليه' ' عمود 4 D الصق فيه متغير TS سطر رقم 2 15 Sheets(sh5n).Cells(E5, 4).Value = TS ' انسخ متغير RN3 16 Range(RN3).Copy ' Sheets(sh5n) = sheet5 'Cells(E5, 5) = سطر متغير E5 ' 5 = عمود E 17 Sheets(sh5n).Cells(E5, 5).PasteSpecial Paste:=xlPasteValues ' إمسح بيانات متغير RN 18 Range(RN).ClearContents ' إنتها الشرط 19 End If ' خروج من حلقة S 20 Next S ' خروج من حلقة R 21 Next R ' الخروج من وضع النسخ الذي 22 Application.CutCopyMode = False ' الخروج من وضع تحديث الشاشة 23 Application.ScreenUpdating = True ' رسالة مسج بنجاح العملية 24 MsgBox "!تـم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تـــــم الـترحـيل" ' مسح بيانات المدى المعني 25 [a5:g14].ClearContents ' الذهاب الى الخلية المعنيه 26 Range("a5").Select ' في حال وجود خطاء On Error GoTo 0 End Sub

اشكرك على كلماتك الطيبه ومانقدمه لاشيء امام مانتعلمه من هذا الصرح الكبير هذا مانتمناه دعوة بظهر الغيب تقبل تحياتي وشكري

السلام عليكم حط هذا الكود في حدث ThisWorkbook Private Sub Workbook_NewSheet(ByVal Sh As Object) Application.ScreenUpdating = False ActiveSheet.DisplayRightToLeft = True Application.ScreenUpdating = True End Sub

السلام عليكم بعد اذن استاذي العزيز احمد يعقوب حفظه الله ورعاه اخي الفاضل goudzy تسهيل لمن اراد المساعده اضف فكرتك في الملف ادرج فورم وضع عليه الازرار اللازمه وإن كان بالاكواد الاساتذة موجودين لن يقصرو معاك تقبل تحياتي

السلام عليكم أضف هذه الأكواد في حدث الفورم Private Sub ALI_P() Dim T% With ActiveSheet For T = 1 To 5 If Me.Controls("checkbox" & T).Value = True Then Select Case T Case Is = 1 .Cells(2, "d").Value = TextBox16.Text Case Is = 2 .Cells(3, "d").Value = TextBox17.Text Case Is = 3 .Cells(4, "d").Value = TextBox18.Text Case Is = 4 .Cells(5, "d").Value = TextBox19.Text Case Is = 5 .Cells(6, "d").Value = TextBox20.Text End Select End If Next End With End Sub Private Sub CommandButton1_Click() ALI_P End Sub وهذا المرفق ALI_CH.rar

هكذا بيكون اذا التلوين من إعدادات الخط Sub ALIDROOS_F() Dim A As Worksheet, B As Worksheet, C As Worksheet Dim V_ALI, I&, T& Set A = Sheets("total"): Set B = Sheets("النموذج الخامس معلم مساعد"): Set C = Sheets("النموذج الرابع اداريين وعمال") L = A.Cells(65535, 1).End(xlUp).Row For V_ALI = 22 To L If A.Cells(V_ALI, 1).Font.Color = RGB(255, 0, 0) Then I = I + 1 A.Cells(V_ALI, 1).Copy Destination:=B.Cells(I, 1) End If If A.Cells(V_ALI, 1).Font.Color = RGB(0, 0, 0) Then T = T + 1 A.Cells(V_ALI, 1).Copy Destination:=C.Cells(T, 1) End If Next End Sub اما اذا التلوين بالتنسيق الشرطي إستعن بالتصفية حسب اللون تحياتي

السلام عليكم الملف عليه كلمة مرور VBA نرجو الغاء كلمة المرور وإرفاقه مرة اخرى

السلام عليكم اطلع على الشرح في المرفق انشاء الله يعمل معاك تحياتي H.rar

السلام عليكم مشكلتك غير ماوضحت في مشاركتي السابقة اضغط ALT + F11 ثم قائمة Tools بعدها References ثم ابحث على هذه الجملة Microsoft Windows Common Controls 6.0 (SP6) والغي منها علامة الصح ان شاء الله يزبط معاك تحياتي

السلام عليكم فورم يأدي نفس الغرض تبحث الاسم المراد ثم اضغط كليك على النتيجة المطلوبه جرب المرفق واي ملاحظات انا موجود تحياتي Orders Original 10000_A.rar

السلام عليكم الاستاذ القدير عبدالله المجرب حفظك الله ورعاك حقيقة موضوع مميز وكلنا نستفيد منه لك منا كل الشكر والتقدير نسأل الله ان يوفقك دنيا واخره وهذه دالة التقريب ربما اكون اصبت Function ALI_I(A As Double) As Double Dim A_1 As Long Dim A_2 As Double Dim A_3 As Double A_1 = Int(A): A_2 = A - A_1 A_3 = A Select Case A_2 Case Is < 0.5 ALI_I = A_1 Case Is = 0.5 ALI_I = A_3 Case Is > 0.5 ALI_I = A_1 + 1 End Select End Function تقبلو تحياتي وشكري

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

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