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

أخي الكريم دربالة يرجى تغيير اسم الظهور للغة العربية ومراجعة التوجيهات في الموضوعات المثبتة في صدر المنتدى إليك الملف بعد تعديله ليتناسب مع الأوفيس 2013 64 بت UserForm TextBox MaxLength Dahy.rar

أخي ومعلمي أبو نصار كود رائع جداً وسريع للغاية حيث أنه يقوم بعمل تجميع للنطاقات التي ينطبق عليها الشروط ملحوظة صغيرة ...في هذا السطر Rng_a = Nothing نضع في البداية كلمة Set

جرب تضع الكود التالي في حدث المصنف Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) '[Save As] يقوم الكود بمنع خاصية الحفظ باسم '------------------------------------------ If SaveAsUI Then MsgBox "I have disabled the 'Save As' function." _ & Chr(10) & "Only 'Save' will work.", vbInformation, "Save As Disabled" Cancel = True End If End Sub

قم بضبط منطقة الطباعة Print Area >> من خلال التبويب Page Layout ثم Print Area ثم حدد النطاق المطلوب العمل عليه .. لا أدري ما المشكلة لديك ولا يمكن التخمين لأبعد من هذا الحد إذا استمرت المشكلة يرجى إرفاق ملفك الأصلي بعد مسح البيانات الحساسة التي بالملف الأصلي تقبل تحياتي

أخي الكريم مصطفى صراحة لم أتابع الموضوع منذ البداية ولكن اطلعت على ملف أخي الحبيب أبو نصار .. واطلعت على سؤالك الأخير بخصوص أن أوراق الطباعة أكثر من صفحتين روح للتبويب View ثم اختر الأمر Page Break Preview ستجد خطوط زرقاء سميكة يمكنك من خلالها التحكم في الصفحات المطلوب طباعتها ..قم بسحب هذه الخطوط بحيث يتناسب مع طلبك أرجو أن يكون المطلوب

أخي الغالي العضو الذهبي ياسر فتحي الأروع هو مرورك العطر وكلماتك الطيبة

مشكور أخي الحبيب الغالي مختار على مرورك العطر الجميل المميز

Sub Ali_Num() Dim WS As Worksheet Dim R, RB, RB_To, Vl, I Set WS = ورقة1 With ورقة18 I = .Range("H4").Value For R = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row If .Cells(R, 1) <> Empty Then RB = Val(.Cells(R, 3)) RB_To = Val(.Cells(R, 4)) Vl = Val(.Cells(R, 1)) WS.Cells(RB - I + 2, "I").Resize(RB_To - RB + 1) = Vl End If Next End With End Sub أخي الكريم أحمد الحاوي ليس من أبدع كمن عدل ..الكود يظل باسم معلمي أبو نصار إليك التعديل البسيط ليؤدي الغرض

بارك الله فيك أخي الحبيب أبا الحسن والحسين على الشرح الرائع والسلس والسهل والممتاز جزيت خيراً أخي الغالي

أخي الحبيب أبو نصار أعتقد أنه لا داعي لاستخدام الحلقات التكرارية المتداخلة حيث أن ذلك يبطيء من عمل الكود ... جرب الكود بهذا الشكل ولاحظ الفرق في سرعة تنفيذ الكودين Sub Ali_Num() Dim SW As Worksheet Dim R, Rb, Rb_To, Vl, i Set SW = ورقة1 With ورقة18 For R = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row If .Cells(R, 1) <> Empty Then Rb = Val(.Cells(R, 3)) Rb_To = Val(.Cells(R, 4)) Vl = Val(.Cells(R, 1)) SW.Cells(Rb + 1, "I").Resize(Rb_To - Rb + 1) = Vl End If Next End With End Sub

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

أخي الكريم الجواد الأبيض أهلا بك في المنتدى ونورت بين إخوانك نتمنى لك قضاء أمتع الأوقات مع إخوانك بالمنتدى جرب الملف التالي عله يفي بالغرض Swimming Heats.rar

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

يا جماعة الخير ..محدش يعرف رقم تليفون علاء رسلان أو يقدر يتواصل معاه ...

ضع الكود في موديول عادي .. يمكنك الإطلاع على رابط الموضوع التالي لمعرفة المزيد من التفاصيل حول كيفية البدء من هنا

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

بارك الله فيك أخي الغالي ياسر فتحي موضوع متميز كسائر موضوعاتك بالتأكيد .. ربما لأن الموضوع مكرر ..!! دائماً ما ينال الجديد الإعجاب .. .. لا تزعل مقصدش أزعلك .. لو زعلت قولي عشان أصالحك تقبل تحياتي

أخي وحبيبي مختار يعجبني فيك التميز في الموضوعات ..تأتي بما لم يأتِ به الأوائل جزيت خير الجزاء

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

يرجى أخي الكريم أبو أمين إرفاق ملف في موضوعاتك اللاحقة لتسهيل المساعدة Private Sub UserForm_Initialize() ListBox1.Selected(ListBox1.ListCount - 1) = True End Sub

أخي الكريم وائل .. بعد إذن أخي وحبيبي في الله زيزو العجوز

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

Sub TestRun() With Range("H5:I6") .FormulaArray = "=Report(A2:C12)" .Value = .Value End With End Sub Function Report(Param As Range) Dim Coll As New Collection, CollDummy As New Collection Dim Rng As Range, ArrIn, ArrHeaderH, ArrHeaderV, ArrOut(), V Dim I As Long, J As Long, Str1 As String ArrIn = Param.Value Set Rng = Application.Caller ArrHeaderH = Rng.Offset(-1).Resize(1).Value ArrHeaderV = Rng.Offset(, -1).Resize(, 1).Value ReDim ArrOut(1 To Rng.Rows.Count, 1 To Rng.Columns.Count) For I = 1 To UBound(ArrIn, 1) Str1 = Trim(UCase(ArrIn(I, 2))) & Chr(2) & Trim(UCase(ArrIn(I, 3))) On Error Resume Next Set CollDummy = Nothing Coll.Add Key:=Str1, Item:=CollDummy Coll(Str1).Add Key:=Trim(UCase(ArrIn(I, 1))), Item:=Empty On Error GoTo 0 Next I For I = 1 To UBound(ArrOut, 1) For J = 1 To UBound(ArrOut, 2) On Error Resume Next ArrOut(I, J) = Coll(Trim(UCase(ArrHeaderV(I, 1))) & Chr(2) & Trim(UCase(ArrHeaderH(1, J)))).Count On Error GoTo 0 Next J Next I Report = ArrOut End Function أخي الكريم أبو جيداء إليك الكود التالي عله يساهم في حل مشكلتك ويسرع من التعامل مع هذا الكم من البيانات Count Unique From Three Columns YasserKhalil.rar

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

بارك الله فيكم إخواني إليكم حل آخر لإثراء الموضوع Sub Find_Today_Date() Dim C As Range, StrDate As Date StrDate = CLng(Date) Set C = ActiveSheet.Cells.Find(What:=StrDate, LookIn:=xlFormulas) If Not C Is Nothing Then C.Select End Sub