ياسر خليل أبو البراء

الاخ الحبيب حسام عيسى بارك الله فيك الأخ صلاح الصغير هذا رابط للموضوع ، الفكرة تقوم على أساس الحفظ كل فترة تقوم بتحديدها كل 10 ثواني ..كل دقيقة ..زي ما تحب http://www.officena.net/ib/index.php?showtopic=56802&hl= وبعدين هي جات ع الكهربا وبس ..دا الكهربا وشوية الغاز وشوية المية المفسفتة .. بكرة تشوفوا مصر واشرب فوسفات وانسى اللي فات تقبل تحياتي

أخي الفاضل ... أيها الأخان الكريمان .. هل أنتما نفس الشخص ؟ أهلا بكما في المنتدى وشرفتم بين إخوانكم يرجى إرفاق ملف للتصور المطلوب ، لكي تجد المساعدة من إخوانك

مشكور على مرورك العطر يا باشمهندس ربنا يديك الصحة وطولة العمر ويبارك فيك ويجازيك خير

أخي الحبيب مختار حسين أخي الحبيب ياسر فتحي بارك الله فيكما .. وجزاكما الله خيراً

جرب الكود بهذا الشكل لإلغاء عملية الفلترة عند الترحيل .. Sub Tarhil() Dim WS As Worksheet, SH As Worksheet Dim strCrt As String Dim I As Long, X As Long X = 6 Set WS = RawData: Set SH = ClientSheet strCrt = SH.Range("T1").Value Application.ScreenUpdating = False SH.Range("A6:R135").ClearContents With WS .AutoFilterMode = False For I = 6 To .Cells(4000, 1).End(xlUp).Row If .Cells(I, "S").Value = strCrt Then .Range(.Cells(I, "A"), .Cells(I, "R")).Copy SH.Range("A" & X).PasteSpecial xlPasteValues X = X + 1 End If Next I End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub وللزوم قم بتغيير الكود لديك بهذا الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$S$1" Or Target.Address = "$S$2" Or Target.Address = "$S$3" Then ActiveWindow.Zoom = 120 Else ActiveWindow.Zoom = 80 End If End Sub تقبل تحياتي

أخي الكريم عند إرفاق ملف في الموضوع يراعى أن يكون مطابق للملف الأصلي يمكن تطبيق الكود على أي نطاق Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)) من خلال هذا السطر تم تعيين النطاق الذي بدايته A2 ونهايته أخر خلية بها بيانات في العمود الاول إذا كان النطاق الخاص بك ثابت من B1:B10 يمكنك استبدال السطر السابق بهذا السطر Set Rng = Range("B1:B10") أما بالنسبة لطلبك الثاني فهو ممكن ولكن يجب تحديد النطاق الذي إذا تغيرت أي قيمة فيه يبدأ تنفيذ الكود يمكن مراجعة الرابط التالي بخصوص هذا الطلب تقبل تحياتي

الأخ الكريم يرجى تغيير اسمك للغة العربية لسهولة التواصل إليك الملف التالي لعله يكون المطلوب Sub UniqueValuesWithinRangeIntoOneCell() Dim Rng As Range, DN As Range, N As Long, SP As Variant Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)) With CreateObject("Scripting.Dictionary") .CompareMode = vbTextCompare For Each DN In Rng SP = Split(DN.Value, ",") For N = 0# To UBound(SP) .Item(SP(N)) = Empty Next N Next DN Range("D5").Value = Join(.Keys, ",") End With End Sub لا تنسى أن تحدد المشاركة كأفضل إجابة إذا أعجبتك تقبل تحياتي Unique Values Within Range Into One Cell.rar

مشكور على مرورك المميز والعطر أخي عمرو

الأخ الفاضل صلاح إليك الملف التالي لعله يكون المطلوب .. أما بالنسبة لكود الزوم فيعمل معي بدون أي مشاكل في الأعمدة 5 و 6 و 7 ... Sub Tarhil() Dim WS As Worksheet, SH As Worksheet Dim strCrt As String Dim I As Long, X As Long X = 6 Set WS = RawData: Set SH = ClientSheet strCrt = SH.Range("T1").Value Application.ScreenUpdating = False SH.Range("A6:R135").ClearContents With WS .AutoFilterMode = False For I = 6 To .Cells(4000, 1).End(xlUp).Row If .Cells(I, "S").Value = strCrt Then .Range(.Cells(I, "A"), .Cells(I, "R")).Copy SH.Range("A" & X).PasteSpecial xlPasteValues X = X + 1 End If Next I .Range("A5:R5").AutoFilter Field:=4, Criteria1:=.Range("S1").Value End With SH.Activate Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Function FilterCriteria(Rng As Range) As String Dim Filter As String Filter = "" On Error GoTo Finish With Rng.Parent.AutoFilter If Intersect(Rng, .Range) Is Nothing Then GoTo Finish With .Filters(Rng.Column - .Range.Column + 1) If Not .On Then GoTo Finish Filter = .Criteria1 Select Case .Operator Case xlAnd Filter = Filter & " AND " & .Criteria2 Case xlOr Filter = Filter & " OR " & .Criteria2 End Select End With End With Finish: FilterCriteria = Filter End Function تقبل تحياتي كشف حساب جديد.rar

الأخ الحبيب صلاح الصغير الأخ الغالي أبا الحسن والحسين الأخ الحبيب ياسر فتحي بارك الله فيكم وجزاكم الله خير الجزاء في الدنيا والآخرة ..ومشكور على مروركم العطر بالموضوع تقبلوا تحياتي

يعني هتفرق ايه لو اديته درجة (مش هتنجحه متخافش ..بس بلاش الاصفار اللي تسد عين الشمس .. لتحصل أزمة في الكرة الأرضية بسبب الصعايدة هههههههه) تقبل تحياتي

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

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

الأخ الحبيب والأستاذ المتميز إبراهيم أبو ليله جزيت خيراً على مرورك العطر ، وأرجو أن تكون الهدية رائعة بالفعل تقبل ودي واحترامي

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

الأخ الحبيب الغالي مختار مشكور على مرورك العطر وعلى تهنئتك لي بمناسبة الـ 5000 مشاركة .. أما بالنسبة للمليون فدا صعب شوية ، بس مش هقولك مستحيل عشان معرفش المستحيل هههههههههههه الأخ الحبيب صلاح الدين الأيوبي مشكور على كلماتك الرقيقة ودعائك الطيب ..بارك الله فيك

الأخ الحبيب مختار تسلم على الإضافة الرائعة بارك الله فيك ..وإن شاء الله دايماً في مزيد من الإبداعات الأخ خالد الشاعر مشكور على مرورك العطر بارك الله فيك

المعادلات أخي الحبيب لن تؤدي ما تطلبه ..فقط بالاكواد أو بالمعادلة التي سبق أن أعطيتك إياها ..

الأخ الفاضل محمد أبو العلا صراحة مبقتش عارف ايه المطلوب قدمت لك حل بالمعادلات .. وحل بالاكواد !! بالنسبة للقائمة المنسدلة روح للخلية اللي فيها القائمة المنسدلة وبعدين روح للتبويب Data ثم Data Validation ثم ستجد في النافذة الأمر Clear All وبذلك تتخلص من القائمة المنسدلة ويمكنك استخدام الخلية لكتابة أي رقم لأي عملية ..

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أقدم لكم اليوم موضوع ليس بجديد على الإطلاق ، ولكن أظن أن الكثيرين لا يعرفونه ، فأحببت أن أشارككم المعلومة علكم تستفيدون ، ولعلكم تنفضون غبار الكسل .. الذي طال أمده موضوعنا عن كيفية إضافة شريط أمر تحكم إلى الكليك يمين ، بمعنى آخر : عندك إجراء فرعي معين ، وبتستخدمه كثيراً ، ومش عايز الإجراء يكون مرتبط بزر أمر ولا يكون تلقائي ، لكن تريد أن يكون موجود في الكليك يمين .. إذاً فالحل بين يديك يتم وضع الكود التالي في حدث فتح المصنف Private Sub Workbook_open() 'هذا الحدث مرتبط بفتح المصنف 'يقوم الكود بإضافة سطر أمر إلى قائمة الكليك يمين 'تعريف متغير من النوع شريط أمر التحكم Dim NewControl As CommandBarControl On Error Resume Next 'حذف شريط الأمر من قائمة الكليك يمين إذا كان موجود من قبل Application.CommandBars("Cell").Controls("Show Date And Time").Delete On Error GoTo 0 'إنشاء أو إضافة شريط أمر التحكم Set NewControl = Application.CommandBars("Cell").Controls.Add With NewControl 'عنوان شريط أمر التحكم الذي سيظهر في قائمة الكليك يمين .Caption = "Show Date and Time" 'مسار واسم الإجراء الفرعي المرتبط بشريط أمر التحكم .OnAction = "Module1.DateAndTime" 'عدم فصل شريط أمر التحكم الجديد بخط .BeginGroup = False End With End Sub وحتى لا تحدث أخطاء في برنامج الإكسيل يراعى أن يتم حذف شريط أمر التحكم الذي تمت إضافته ولذا ستجد الكود التالي في حدث إغلاق المصنف Sub Workbook_BeforeClose(Cancel As Boolean) 'هذا الحدث مرتبط بإغلاق المصنف On Error Resume Next 'هذا السطر لحذف الأمر - الذي تمت إضافته عند فتح المصنف - من قائمة الكليك يمين Application.CommandBars("Cell").Controls("Show Date and Time").Delete End Sub وهذا هو الكود المرتبط تنفيذه بشريط أمر التحكم Sub DateAndTime() 'هذا هو الماكرو الذي تمت إضافته لقائمة الكليك يمين MsgBox "Today is: " & Format(Date, "dd. mm. yyyy") & "." & vbCr & vbCr & "It is: " & Format(Time, "hh:mm:ss") End Sub وأخيراً تقبلوا تحيات أخوكم أبو البراء دمتم على طاعة الله Add Control To Right Click Menu.rar

سبقتني يا مختار كالعادة بارك الله فيك أخي الزباري وعقبال ما نبارك لك على المشاركة رقم 10000 ... وبارك لي على المشاركة رقم 5000 :dance1:

أخي الحبيب الغالي مختار بارك الله فيك وجزاك الله خيراً على كل ما تقدمه بس إنت تاعب نفسك ليه كدا بأزرار الأوامر (خليك كسول زي حالاتي عشان توصلك لأقصر الحلول ..بلاش الطرق الوعرة الطويلة يا صاحبي) جرب الملف التالي لعله يكون أقصر الطرق .. Private Sub UserForm_Initialize() Dim I As Integer For I = 1 To 24 With cbNumberOfPages .AddItem I End With Next I End Sub Private Sub cmdPrint_Click() If Tx_Copies.Value = "" Then MsgBox "أدخل عدد النسخ المراد طباعتها": Exit Sub If cbNumberOfPages.Value = "" Then MsgBox "أدخل عدد الصفحات المطلوبة للطباعة": Exit Sub On Error Resume Next Sheets("Feuil1").Select ActiveWindow.SelectedSheets.PrintOut From:=1, To:=cbNumberOfPages.Value, Copies:=Tx_Copies.Value, Collate:=True Sheets("Feuil2").Select End Sub Private Sub cmdEnd_Click() End Sheets("Feuil2").Select End Sub تقبل تحياتي Print UserForm Mokhtar.rar

السلام عليكم ورحمة الله وبركاته إخواني الأحباب في المنتدى الغالي هل فكرت يوماً ؟ إذاً أنت موجود .. لأن الحكمة بتقول : أنا أفكر إذاً أنا موجود ، وبتعديل بسيط ممكن نقول : أنا أؤمن بالله إذاً فالله موجود وأنا حي القلب قبل حياة الجسد سرحت اعذروني أقدم لكم اليوم كود جديد ، يقوم الكود كما هو موضح بالعنوان (والموضوع بيبان من عنوانه ..فمحدش يتوه مني عشان أنا متعمد أتوهكم) ..كما هو موضح يقوم الكود بتنفيذ الماكرو أو الإجراء الفرعي عدد معين من المرات ، يمكنك أن تحدد عدد المرات في الملف المرفق قمت بوضع عدد المرات في الخلية C3 ويمكن تغييره بالطبع ، كما يمكن أيضاً (عشان الناس متقولش إني بخلان عليكم بمعلومة) ممكن أن تغير في الكود لتضع عدد مرات التكرار الذي ترغبه داخل الكود ، وذلك من خلال تغيير هذا السطر nTimes = Range("C3").Value إلى هذا السطر nTimes = 3 إذاً فأنت حر في اختيارك لطريقة وضع قيمة المتغير المرتبط بعدد مرات التكرار وإليكم الكود بالشكل الكامل (والكمال لله وحده) 'تعريف المتغير الذي يمثل عداد لعدد مرات تنفيذ الماكرو Dim I As Integer Sub RunMacroNTimes() 'تعريف المتغير الذي يمثل عدد مرات تنفيذ الماكرو Dim nTimes As Integer 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'وضع القيمة صفر للعداد I = 0 '[C3] ليساوي قيمة الخلية [nTimes] تعيين قيمة للمتغير nTimes = Range("C3").Value 'حلقة تكرارية لتكرار تنفيذ الماكرو طبقاً لقيمة الخلية Do While I < nTimes 'زيادة قيمة العداد بمقدار واحد في كل حلقة تكرارية I = I + 1 'استدعاء الماكرو المراد تنفيذه Call Test 'الانتقال داخل الحلقة التكرارية إلى أن تساوي قيمة العداد قيمة الخلية Loop 'إظهار رسالة تفيد بعدد مرات تنفيذ الماكرو MsgBox "تم تنفيذ الماكرو " & I & " مرات" 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub Sub Test() MsgBox "مرحباً بكم إخواني .. الترحيب رقم " & I End Sub وعشان خاطر عيون حبايبي اللي زعلانين مني (وهما عارفين مين .. وكل لبيب بالإشارة يفهم .. ومش عايز حد يكون ساخـ (هـ) ـــر مني) قمت بشرح أسطر الكود للاستفادة منه في أكواد أخرى كما أقدم لكم ملف مرفق للإطلاع عليه (ودا عشان الناس الكسلانة .. شايف مختار بيحمل الملف المرفق .. لا إنت لا إنت طبقه بنفسك) وأخيراً تقبلوا تحياتي ودمتم في رعاية الله Run Macro Number Of Times YasserKhalil.rar

الأخ الكريم عبد العزيز البسكري مشكور على مرورك العطر وجزاك الله خير الجزاء على تشجيعك الدائم لي تقبل تحياتي

جزاكم الله خيراً أخي الحبيب مختار بارك الله فيك ولا حرمنا الله من روائعك الجديدة والمفيدة تقبل تحياتي