رجب جاويش

أخى الفاضل / سليم عمل رائع تسلم ايديك

السلام عليكم أخى الفاضل جرب الكود بعد هذا التعديل 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

أخى الفاضل مرحبا بك فى منتدى أوفيسنا العريق أولا : لك منى دعوة طيبة بتغيير إسم الظهور إلى اللغة العربية ليسهل التواصل بيننا ( طبقا لسياسة المنتدى ) ثانيا : يوجد بالفعل دورة مكتملة فى VBA على الرابط التالى http://www.officena.net/ib/index.php?showtopic=39323

بعد اذن أخى الحبيب / محمد أبو البراء وأخى الحبيب / حمادة عمر هذا هو تصورى وفهمى للفكرة جمع القيم التى يتم ادخالها فى نفس الخلية Private Sub Worksheet_Change(ByVal Target As Range) Static x If Target.Address = [A1].Address Then Application.EnableEvents = False x = x + Target.Value Target = x Application.EnableEvents = True End If End Sub جمع عدة قيم فى خليه واحدة.rar

أخى الفاضل / فراس أرجو التوضيح أكثر فيما يخص جدول المتغيرات ما هى البيانات المراد وضعها فى هذا الجدول

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

أخى الفاضل / محمد الخازمي جزاك الله كل خير

أخى الحبيب / محمد أبو البراء جزاك الله كل خير

أخى الفاضل / أبو إيمان جزاك الله كل خير

السلام عليكم أخى الفاضل / سليم تسلم ايديك ولإثراء الموضوع هذا حل آخر 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

أخى الفاضل / عمرو أولا : شكرا جزيلا على تغيير الإسم الى إسم واضح ثانيا : لا يوجد أى مشكلة تمنع الرد على المطلوب وعمل اللازم فلا تقلق

أخى الفاضل / محمد جزاك الله كل خير

أخى الحبيب / محمد أبو البراء جزاك الله كل خير

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

السلام عليكم تفضل أخى والشكر موصول لأستاذ الأجيال / عبد الله باقشير الذى تعلمنا منه هذه الإبداعات 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

أخى الفاضل / فراسكو جزاك الله كل خير وان شاء الله أقوم بشرح الكود

أخى الفاضل / فراسكو الكود يعمل الى آخر صف أيا كان رقمه وهو يعمل فى المرفق حتى الصف 1270

السلام عليكم تفضل أخى تم تعديل بسيط وجعل الكود يعمل عن طريق زر حتى يمكن تنفيذ طلبك جرب وأخبرنى بالنتيجة 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

أخى الفاضل / احمد الحاوي جزاك الله كل خير أخى الفاضل على هذه الكلمات الطيبة

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

أخى الحبيب / حمادة عمر ( أبو سما ) جزاك الله كل خير تقبل أرق تحياتى

أخى الحبيب / إبراهيم جزاك الله كل خير تقبل أرق تحياتى

السلام عليكم وهذه محاولة أخرى لإثراء الموضوع كود فى حدث الصفحة بمجرد كتابة الكلمة المطلوبة يتم الترحيل Private Sub Worksheet_Change(ByVal Target As Range) Set sh = Sheets("الخلاصة") LR = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 If Target.Count > 1 Then Exit Sub Application.ScreenUpdating = False If Not Intersect(Target, Range("G:G")) Is Nothing Then If Not IsEmpty(Target) And Target.Text = "تخويل صادر" Or Target.Text = "شهيد" Or Target.Text = "دورة" Or Target.Text = "نقل" Or Target.Text = "استخدام" Or Target.Text = "حماية" Then Target.Offset(0, -6).Resize(1, 4).Copy sh.Range("A" & LR).PasteSpecial xlPasteValues sh.Range("E" & LR).Value = Target End If End If Application.CutCopyMode = False Application.ScreenUpdating = True Set sh = Nothing End Sub المصنف2.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

السلام عليكم تفضل أخى Sub ragab() Application.OnTime Now + TimeValue("00:00:20"), "clor" End Sub Sub clor() Randomize x = Int(Rnd(1) * 255 + 1) y = Int(Rnd(1) * 255 + 1) Z = Int(Rnd(1) * 255 + 1) Range("A1").Interior.Color = RGB(x, y, Z) Call ragab Exit Sub End Sub Sub Auto_Open() Call ragab End Sub تغيير لون خلية كل 20 ثانية.rar