رجب جاويش

أخى الفاضل
جرب المرفق
Book123.rar

أخى الفاضل / أحمد
بداية
أهلا بك عضو جديدا بين إخوانك
 
ستجد فى المرفقات ملف به  شرح كود من أكواد الترحيل
 
ولكن يجب أن تعلم أن الكود يختلف من ملف لآخر حسب معطيات كل ملف وطريقة وضع البيانات فيه
 
ثانيا
أرجو الأنتباه فى المرة القادمة
وعدم وضع اسم عضو معين باسمه داخل أى طلب لان هذا قد يعرض موضوعك للحذف من قبل المشرفين وحتى لا تحرم نفسك من اسهامات بقية الأعضاء
 
 
شرح كود فصل الناجحين والراسبين1.rar

السلام عليكم
بعد اذن الأستاذ / زيزو العجوز
جرب أخى هذه المعادلة
=IFERROR(INDEX($I$2:$I$1000;MATCH(TRUE;A2&B2=$G$2:$G$1000&$H$2:$H$1000;0));"") مع مرعاة الضغط على ctrl + shift + enter
 
coulm.rar

السلام عليكم
تفضل أخى
 
الملف.rar

السلام عليكم
تفضل أخى
 
اضافة محرك بحث الى شيت البيانات.rar

السلام عليكم
تفضل أخى ما تريد
تم التطبيق على ورقة 2
كلمة المرور 123
منع دخول الصفحة الابرقم سري.rar

السلام عليكم
تفضل أخى ما تريد
 
Suppliers Coder - Copy.rar

السلام عليكم
أخى الفاضل
تم تنفيذ ما طلبت مع تعديل بسيط فى الفكرة الأولى وأرجو أن تعجبك
جعلت كلمات المرور مرتبطة بأيام الشهر بحيث
فى الأيام السبعة الأولى من الشهر تكون كلمة المرور  ( الله اكبر )
وفى الأيام السبعة التالية تكون كلمة المرور  ( سبحان الله )
وفى الأيام السبعة التالية تكون كلمة المرور ( الحمد لله )
وفى الأيام السبعة الأخيرة تعود كلمة المرور كما كانت وهى ( الله اكبر )
وهكذا فى كل شهر
 
أما غلق محرر الأكواد فيمكنك ذلك عن طريق الدخول الى محرر الأكواد
ثم من قائمة Tools  تختار VBAProject properties 
ثم تختار تبويب protection
وتضع علامة صح امام الاختيار look project for viewing
ثم تضع كلمة المرور فى خانة     password
وتعيد كتابتها مرة أخرى فى خانة confirm password
 
وفى الملف المرفق كلمة مرور محرر الأكواد 123
كلمة مرور متغيرة كل 7 أيام.rar

السلام عليكم
أخى الفاضل
جرب هذا الكود
ولكن يجب تعديل تواريخ الأيام فى باقى الصفحات بحيث يكون مثل صفحة 2015
Sub ragab() Dim cl As Range Application.ScreenUpdating = False T = Range("B1").Text On Error Resume Next Set Rng = Sheets(T).Range("C2:ND2") For Each cl In Rng If Range("c2") = cl Then x = cl.Column Range("C3:C35").Copy Sheets(T).Cells(3, x).PasteSpecial xlPasteValues Application.CutCopyMode = False Exit For End If Next Application.ScreenUpdating = True End Sub حيث أن الكود يعمل تمام عند الترحيل الى صفحة 2015
 
Data.rar

السلام عليكم
أستاذى الفاضل / محمد يوسف
عذرا لتأخرى عليك فى الرد بسبب انقطاع النت عندى لفترة طويلة
 
تفضل ما تريد فى الملف المرفق
 
سحب المعادلات 3.rar

أخى الفاضل  / خالد
استبدل السطر التالى
If Target.Value < 15 Then Target.Interior.ColorIndex = 3 بهذا السطر
If Target.Value < Cells(13, Target.Column).Value Then Target.Interior.ColorIndex = 3

السلام عليكم
أخى الفاضل
جرب المرفق
 
مثال إستبدال اسماء الفروع.rar

أخى الفاضل / محمد
أولا : مرحبا بين إخوانك عضوا جديدا فى منتدى أوفيسنا العريق
ثانيا : لك منى دعوة طيبة بتغيير اسم الظهور إلى اللغة العربية ليسهل التواصل بيننا ( طبقا لسياسة المنتدى ) تأكيدا لما قاله أخى الحبيب / محمود الشريف
ثالثا : يرجى وضع ملف مرفق حتى يمكن العمل عليه توفيرا للوقت والجهد
 
 
قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة
و بصفة خاصة نؤكدعلى ما يلي
1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة
2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد.
3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال.
4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا.....
5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم.
ومخالفة ذلك تعرض الموضوع للحذف

السلام عليكم
تفضل أخى
 
تجربة.rar

السلام عليكم
أخى الفاضل
إجعل الكود بالشكل التالى
Public ss As Byte Sub addition() Dim ER, R pass = "123" sama = InputBox("إدخل الباسورد لتنفيذ الماكرو") If sama <> pass Then ss = ss + 1 MsgBox ("الباسورد خطأ (الإدخال الخاطئ اكثر من 3 محاولات يقفل البرنامج)" & Chr(10) & " " & "باقى لك عدد" & " " & 3 - ss & " " & "محاولة") If ss >= 3 Then Application.DisplayAlerts = False Application.Quit End If Exit Sub End If ER = ActiveSheet.UsedRange.Rows.Count For R = 8 To ER If WorksheetFunction.IsNumber(Cells(R, 7)) = True And _ Cells(R, 7) <> 0 Then Cells(R, 7) = Cells(R, 7) + 1 If WorksheetFunction.IsNumber(Cells(R, 23)) = True And _ Cells(R, 23) <> 0 Then Cells(R, 23) = Cells(R, 23) + 1 Next R End Sub

السلام عليكم
أخى الفاضل
هل تقصد هكذا
 
تسديد اشتراك.rar

السلام عليكم
أخى الفاضل
إجعل كود اظهار الفورم بالشكل التالى
Sub ragab() UserForm1.Show 0 End Sub

السلام عليكم
أخى الفاضل
جرب الكود بعد هذا التعديل
Sub Macro6() ' ' Macro6 a~C,?N~? ' ' Application.ScreenUpdating = False Sheets("ALIELBASRY").Select Range("A11:T65").Select Selection.AutoFilter ActiveWindow.SmallScroll Down:=-12 Range("A11").Select ActiveSheet.Range("$A$11:$T$65").AutoFilter Field:=1, Criteria1:="<>" Range("E12").Select Sheets("ALIELBASRY").Select Range("E5:P5").Select Application.Dialogs(xlDialogPrinterSetup).Show ansr = MsgBox("هل تريد اتمام عمليه الطباعة", vbYesNo, "طباعة") If ansr = vbNo Then GoTo 1 ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _ IgnorePrintAreas:=False Sheets("Data").Select 1 End Sub

السلام عليكم
أخى الفاضل / سليم
تسلم ايديك
ولإثراء الموضوع هذا حل آخر
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim R_N As Integer Dim C_N As Integer Dim i As Integer Dim ii As Integer '=========================================== Cells.Interior.ColorIndex = 0 R_N = ActiveCell.Row C_N = ActiveCell.Column '=========================================== For i = 1 To R_N Cells(i, C_N).Interior.ColorIndex = 6 Next For ii = 1 To C_N Cells(R_N, ii).Interior.ColorIndex = 6 Next Cells(R_N, C_N).Interior.ColorIndex = 5 End Sub تلوين الصف والعمود الخاص بالخلية النشطة.rar

السلام عليكم
تفضل أخى
والشكر موصول لأستاذ الأجيال / عبد الله باقشير الذى تعلمنا منه  هذه الإبداعات
Sub ragab1() Dim i As Integer Dim x As Integer Application.ScreenUpdating = False For i = 10 To 406 Step 4     If Cells(i, "AE").Value = "منتقل" Then         x = Cells(i, "AE").Row         Range("A" & x & ":AE" & x + 3).EntireRow.Hidden = True     End If Next Application.ScreenUpdating = True End Sub Sub Hide_Show() On Error Resume Next Dim XX As Shape Set XX = ActiveSheet.Shapes("إخفاء") With XX.TextFrame.Characters     If .Text = "إخفاء منتقل" Then        ragab1        .Text = "إظهار منتقل"     Else        ragab2        .Text = "إخفاء منتقل"     End If End With End Sub Sub ragab2() Cells.Rows.Hidden = False End Sub اخفاء صف بشرط.rar

السلام عليكم
تفضل أخى
تم تعديل بسيط
وجعل الكود يعمل عن طريق زر
حتى يمكن تنفيذ طلبك
جرب وأخبرنى بالنتيجة
Sub ragab() Dim c As Range Set sh = Sheets("الخلاصة") LR = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False sh.Range("A3:E1000").ClearContents For Each c In Range("G4:G" & LR) If Not IsEmpty(c) And c.Text = "تخويل صادر" Or c.Text = "شهيد" _ Or c.Text = "دورة" Or c.Text = "نقل" Or c.Text = "استخدام" Or c.Text = "حماية" Then c.Offset(0, -6).Resize(1, 4).Copy LR1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & LR1).PasteSpecial xlPasteValues sh.Range("E" & LR1).Value = c End If Next Application.CutCopyMode = False Application.ScreenUpdating = True Set sh = Nothing End Sub المصنف3.rar

السلام عليكم
أخى ابراهيم
جرب الكود التالى
Sub ragab() Dim FilePath As String Dim fName As String Application.ScreenUpdating = False Range("A:A").Clear FilePath = ActiveWorkbook.Path & "\" fName = Dir(FilePath & "*.xls") Do While Len(fName) > 0 Range("A1") = "أسماء الملفات" x = Left(fName, Len(fName) - 4) If x = "الرئيسية" Then GoTo 1 Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = x ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Rows.Count).End(xlUp), Address:=fName, _ TextToDisplay:=Range("A" & Rows.Count).End(xlUp).Value 1 fName = Dir Loop Sheets("Sheet1").Range("A:A").Font.Size = 14 Columns("A:A").Columns.AutoFit Application.ScreenUpdating = True End Sub Hyperlinks.rar

السلام عليكم
تفضل
 
تنسيق شرطي.rar

السلام عليكم
تفضل أخى
 
2معادلة حسابية.rar

السلام عليكم
بعد اذن أخى الفاضل / سليم
 
أخى الفاضل
جرب التعديل التالى
Private Sub TextBox1_Change() Dim b As Boolean Me.TextBox2 = "" Me.TextBox3 = "" Set sh12 = Sheets("Sheet1") LR = sh12.[G20000].End(xlUp).Row If Me.TextBox1 = "" Then Exit Sub For Each cl In sh12.Range("G2:G" & LR) If (Val(Me.TextBox1)) = cl Then b = True Me.TextBox2 = cl.Offset(0, 1) Me.TextBox3 = cl.Offset(0, 2) Exit For End If Next If Not b Then   MsgBox "لاتوجد نتائج للبحث", vbMsgBoxRight, "عفوا" End If End Sub