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

هل الطابعة المثبتة على الأجهزة طابعة واحدة ؟؟أم أن هناك أكثر من طباعة مثبتة ؟

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

حاول أن تتجنب في كتابة الأكواد عملية التحديد فهي تبطيء عمل الكود مع البيانات الكثيرة

ربما كود بهذا الشكل يفي بالغرض Sub Test() If Range("A1").Value = "No" Then Range("B1").ClearContents End Sub

أخي الحبيب سليم مشكور على إثراءك للموضوع .. أعتقد أن فهمك للموضوع مختلف ..النتائج على ما أعتقد وعلى ما قمت بعمله أنا والأخ خالد صحيحة جرب المعادلة =IF(B2>0,MIN(INDIRECT("A"&ROW()+1&":A"&COUNT($A$1:$A$500))),"") ستجد أنها نفس النتائج للكود المقدم .. العمل يكون على النطاق بالكامل بدءاً من الصف التالي للصف الحالي وحتى آخر صف تقبل تحياتي

الموقع مغلق .. ولا ايه الموضوع خير اللهم اجعله خير مكتوب مغلق للصيانة ودا رد لتجربة هل الموقع شغال أم لا؟

أخي الحبيب ياسر فتحي إليك الكود التالي عله يفي بالغرض بالنسبة لملفك في المشاركة الأولى قمت بإزالة التنسيقات في الأعمدة والصفوف الزائدة ...لا أرى داعي أبداً لتنسيق كافة الصفوف والأعمدة بهذا الشكل ، هذا يجعل الملف ثقيل وبطيء جداً المهم اتفضل الكود جرب وشوف Sub PullUniques() Dim A, I As Long, J As Long, N As Long, LR As Long With Sheets("Sheet1") LR = .Columns("B:M").Find("*", , , , xlByRows, xlPrevious).Row A = .Range("B3:M" & LR).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For J = 1 To UBound(A, 2) For I = 1 To UBound(A, 1) If Len(A(I, J)) Then If Not .Exists(A(I, J)) Then .Item(A(I, J)) = Empty: N = N + 1 If N <> I Then A(N, J) = A(I, J): A(I, J) = Empty Else A(I, J) = Empty End If End If Next I N = Empty Next J End With .Range("O3").Resize(UBound(A, 1), UBound(A, 2)).Value = A End With End Sub تقبل تحياتي Customers New Only YasserKhalil.rar

إنت كدا بتطلب شيء صعب جداً .. أعتقد إن مفيش مشكلة من الاستخراج لن يستغرق الامر طويلا بعدها يمكنك المعاينة والطباعة كما تريد جرب الملف التالي عله يفي بالغرض Export Workbooks Using Filter Method V2.rar

اطلعت على الملف ولم أجد روابط تشعبية يرجى التوضيح للمطلوب بدقة ... بالنسبة لحذف الارتباطات التشعبية استخدم الكود التالي Sub NoLinks() 'يقوم الكود بإزالة كل الارتباطات التشعبية في ورقة العمل النشطة '------------------------------------------------------------ ActiveSheet.Hyperlinks.Delete End Sub

أخي الكريم تم إضافة الكود التالي في موديول Public Sub PrintPreview(FullName As String) Dim XL As Excel.Application Dim Wrk As Excel.Workbook Dim Sht As Excel.Worksheet If Dir(FullName) = "" Then MsgBox "Can't Find File!", vbCritical Exit Sub End If Set XL = New Excel.Application Set Wrk = XL.Workbooks.Open(FullName) Set Sht = Wrk.ActiveSheet XL.Visible = True XL.WindowState = xlMaximized Sht.PrintPreview Wrk.Saved = True XL.Quit End Sub ثم في حدث الفورم حذفت ما كان موجود وأضفت التالي كما حذفت الفورم الثاني نظراً لعدم الحاجة إليه Private Sub UserForm_Initialize() Dim Cell As Range For Each Cell In Range("X12:X23") ComboBox1.AddItem Cell.Value Next Cell End Sub Private Sub cmdPrint_Click() Dim FullName As String If ComboBox1.Value = "" Then MsgBox "لم يتم اختيار مصنف لمعاينة الطباعة", 64: Exit Sub FullName = ThisWorkbook.Path & "\Results\" & ComboBox1.Value & ".xlsx" Unload Me PrintPreview FullName End Sub وإليك الملف فيه تطبيق ما طلبت إن شاء الله لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي تقبل تحياتي Export Workbooks Using Filter Method V2.rar

أخي الكريم ياسر في النتائج المرفقة في شهر مارس ؟ وضعت رقم 10 وهو موجود في شهر يناير مسبقاً ..ما مدى صحة المنطق؟ هل هذه النتيجة صحيحة بهذا الشكل؟ وكذلك الرقم 41 في النتئج المرفقة موجود من قبل في شهر فبراير؟؟ أكد أو انفي

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

بارك الله فيك أيها المتمكن خالد صراحة يعجبني أسلوبك في المعادلات بشكل رهيب وخصوصاً الدالة INDIRECT ..كأنها سحر المعادلات

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

أخي الحبيب خالد بارك الله فيك وجزيت خيراً نسيت تثبت النطاق الخاص بالعد =IF(B2>0,MIN(INDIRECT("A"&ROW()+1&":A"&COUNT($A$1:$A$500))),"") جرب الكود التالي عله يفي بالغرض Sub ExtractMinNumbers() Dim Cell As Range For Each Cell In Range("B2:B" & Cells(Rows.Count, 1).End(xlUp).Row) If Not IsEmpty(Cell) Then Cell.Offset(, 1) = Application.WorksheetFunction.Min(Range(Cells(Cell.Row + 1, 1), Cells(Rows.Count, 1))) Next Cell End Sub

إليك أخي الفاضل الملف التالي عله يكون المطلوب تم عمل ورقة تقرير ..اختار الاسم ثم انقر زر الأمر لتظهر البيانات المرتبطة بهذا الاسم Sub Report() Dim WS As Worksheet, SH As Worksheet Dim I As Long, lRow As Long, LR As Long Set WS = Sheets("نور البيان "): Set SH = Sheets("Report") lRow = 6 Application.ScreenUpdating = False With SH.Range("D6:K1000") .ClearContents: .Interior.Color = xlNone End With Call UniqueNames For I = 7 To 506 If WS.Cells(I, "C") = SH.Cells(3, "C") Then WS.Cells(I, "C").Offset(, 1).Resize(1, 8).Copy SH.Cells(lRow, "D").PasteSpecial xlPasteValues lRow = lRow + 1 End If Next I SH.Range("D7:H1000").ClearContents LR = SH.Cells(Rows.Count, "I").End(xlUp).Row + 1 With SH.Range("I" & LR) .Formula = "=SUM(I6:I" & LR - 1 & ")": .Value = .Value: .Interior.Color = 10092441 If .Value = SH.Range("H6") Then MsgBox "تم سداد المبلغ بالكامل", 64 Else MsgBox "المبلغ لم يتم سداده بالكامل ما زال هناك أقساط متبقية", vbExclamation End If End With SH.Range("C3").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Sub UniqueNames() Dim Rng As Range Dim Dn As Range Dim Dic As Object With Sheets("نور البيان ") Set Rng = .Range("C7:C506") End With Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMode = vbTextCompare For Each Dn In Rng If Not IsEmpty(Dn) Then Dic(Dn.Value) = Empty Next Dn Sheets("Report").Columns(15).ClearContents Sheets("Report").Range("O1").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.keys) End Sub Report Summary.rar

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

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

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

ما هو نظام التشغيل الذي تعمل عليه لوكان ويندوز 7 يمكنك من خلال لوحة التحكم Control Panel النقر على Region and language ثم التبويب Administrative ثم انقر الزر المكتوب عليه Change System Locale واختار من القائمة أي دولة عربية ثم موافق ثم أعد تشغيل الجهاز

بارك الله فيك أخي المتميز أحمدعبد الناصر يعجبني فيك البساطة في تقديم الحلول (السهل الممتنع) في حقيقة الأمر فكرت في الاستعانة بجدول في بداية الأمر ولكن أحببت أن تكون الدالة عامة يمكن استخدامها لمن يريد استخدامها دون التقيد بنطاق محدد داخل ورقة العمل عموماً في كلٍ خير إن شاء الله المهم أبو لجين يطرح الموضوع ويختفي !!!!!!!!!! طالما أنك استعنت بجدول يمكن استخدام معادلة الصفيف التالية ضع المعادلة في الخلية H4 واسحب المعادلة وستحقق نفس النتائج =SUM(IFERROR(IF(CODE(MID(F4,TRANSPOSE(ROW(INDIRECT("1:100"))), 1))=CODE($A$1:$A$100),$B$1:$B$100),0)) لا تنسى أن تضغط Ctrl + Shft + Enter

لا يوجد في المرفق عمود الانقطاع يرجى الدقة أخي الكريم إليك المعادلة التالية فيها إجمالي الخصم للأربعة أعمدة D - J - P - Q ضع المعادلة في الخلية AE2 =SUM((D2/30)*AD2,(J2/30)*AD2,(P2/30)*AD2,(Q2/30)*AD2) إذا حدث خطأ أثناء نسخ ولصق المعادلة قم باستبدال الفاصلة بفاصلة منقوطة في المعادلة إذا لم تفي المعادلة بالغرض يرجى مزيد من التوضيح وضرب أمثلة بالنتائج المتوقعة (لأنه لا يفترض بالأعضاء معرفة الأمور المالية الخاصة بحساباتك)

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

أخي الكريم أين تريد المعادلات الخاصة بالخصم ...؟؟

أخي الفاضل أبو لجين إليك الدالة التالية وإن شاء الله تفي بالغرض بالنسبة لأي طلب جديد لا يخص هذا الطلب يرجى طرح موضوع مستقل Function CalString(sInp As String) As Long Static bInit As Boolean Dim asMap() As String Dim asLtr() As String Dim I As Long Static aiVal(0 To 255) As Long If Not bInit Then asMap = Split("1 1 1 1 1 1 2 3 4 5 6 7 8 9 10 20 30 40 50 60 70 80 90 100 200 300 400 500 600 700 800 900 1000") asLtr = Split("ء أ إ آ ا ئ ب ج د ه و ز ح ط ي ك ل م ن س ع ف ص ق ر ش ت ـة ث خ ذ ض ظ غ") For I = 0 To UBound(asMap) aiVal(Asc(asLtr(I))) = asMap(I) Next I bInit = True End If For I = 1 To Len(sInp) CalString = CalString + aiVal(Asc(Mid(sInp, I, 1))) Next I End Function وإليك أيضاً ملف مرفق فيه تطبيق لاستخدام الدالة تقبل تحياتي ABJAD Calculator UDF Function YasserKhalil.rar