نجوم المشاركات

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

اخى الكريم لعلك قد نسيت حذف بعض اسطر الكود الغير هامة لهذا اليك المرفق بعد التعديل استخدمت الامر WAIT لجعل لون ناتج البحث احمر وذلك لمدة ثانية ثم يرجع اسود بحث.rar

إليك الطلب الأول Sub ConvertFormulaVBA() Dim LR As Long LR = Cells(Rows.Count, "D").End(xlUp).Row With Range("R8:R" & LR) .Formula = "=(T8*V8)/U8" .Value = .Value End With With Range("S8:S" & LR) .FormulaArray = "=Wish(D8:R" & LR & ",X12:Y23,3,14,15,10)" .Value = .Value End With End Sub بحيث لا تحدد آخر صف بنفسك بالنسبة للطلب الثاني إليك الكود Sub YasserKhalil() Dim rngData As Range, rngToCopy As Range, arrFilter, I As Long, J As Long Application.DisplayAlerts = False Application.ScreenUpdating = False If Len(Dir(ThisWorkbook.Path & "\Results", vbDirectory)) = 0 Then MkDir ThisWorkbook.Path & "\Results" End If Set rngData = Range("D7:S" & Cells(Rows.Count, "D").End(xlUp).Row) arrFilter = Application.Transpose(Range("X12:X" & Cells(Rows.Count, "X").End(xlUp).Row)) ReDim Preserve arrFilter(1 To UBound(arrFilter) + 1) arrFilter(UBound(arrFilter)) = "<>بدون توجيه" For I = 1 To UBound(arrFilter) ActiveSheet.AutoFilterMode = False rngData.AutoFilter Field:=16, Criteria1:=arrFilter(I) J = rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count If J = 1 Then GoTo skipper Set rngToCopy = Intersect(Union(Columns("D:E"), Columns("R:S")), rngData.SpecialCells(xlCellTypeVisible)) Workbooks.Add With ActiveSheet.Cells .Clear .FormatConditions.Delete End With rngToCopy.Copy Range("B5").PasteSpecial xlPasteValues Columns(2).ColumnWidth = 11: Columns(3).ColumnWidth = 28: Columns(4).ColumnWidth = 10.5: Columns(5).ColumnWidth = 15 With Range("B2:E3") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .MergeCells = True .Font.Size = 20 .Value = IIf(I < UBound(arrFilter), arrFilter(I), "قوائم التوجهات الكلية") End With If I < UBound(arrFilter) Then Columns("E").Delete FormatRange ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & arrFilter(I) & ".xlsx" Else FormatRange ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & "قوائم التوجهات الكلية" & ".xlsx" End If ActiveWorkbook.Close skipper: Next I ActiveSheet.AutoFilterMode = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub FormatRange() With Range("B5").CurrentRegion .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 13 .Borders.Weight = xlThin .BorderAround Weight:=xlThick End With Range("B2").Select End Sub إذا كان فيه أي طلبات أخرى يرجى طرح موضوع جديد حيث أنه يفضل أن يكون كل موضوع لطلب واحد فقط ... وصل الموضوع هنا إلى 4 طلبات ( ......................)

اخى الكريم المطلوب غير واضح بل لعلة غير معروف ...... لذلك اليك المرفق التالى جربة وابدى ملاحظاتك لمن يهمه الامر 2- 2016.rar

السلام عليكم و رحمة الله و بركاته تحياتي لأساتذتي الكرام و اخواني و اخواتي الزوار و الاعضاء.. بعد عناء طويل و بحث مستمر بفضل من الله و منة حظيت بمعرفة ارفاق التقرير بباركود QR او اي صيغة انت تريدها الملفات و الفيديوهات التعليمية في عنوان الدروب بوكس .. حجم الملف مع البرامج 92 م البرامج لل 64 بت و 32 بت شكرآ لقبولكم هديتي البسيطة راجيآ من حضرتكم الدعاء و راجيآ من الله لي و لكم الافادة https://www.dropbox.com/s/dc7gcdg6fi80oz4/الباركودات مع البرنامج.rar?dl=0

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

أخي الحبيب الشهابي لا أعتقد أن هذا هو المطلوب قم بالإطلاع على المرفق التالي لعل الأمور تكون أوضح Public Function GetItemTestCount(ItemTest As String, Criteria As String) As Long Dim Sht As Excel.Worksheet Dim Arr, lRow Dim Tally As Long, Count As Long Arr = Array("يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Application.Volatile Tally = 0 For Each Sht In ThisWorkbook.Worksheets If UBound(Filter(Arr, Sht.Name)) > -1 Then lRow = Application.WorksheetFunction.Match(ItemTest, Sht.Range("'" & Sht.Name & "'!$A$5:$A$500"), 0) + 4 If Criteria <> vbNullString Then Count = Application.WorksheetFunction.CountIf(Sht.Range("C" & lRow & ":" & "AG" & lRow), Criteria) Tally = Tally + Count End If Next GetItemTestCount = Tally End Function تقبل تحياتي Ehsaa UDF Function.rar

أخي العزيز / زياد يمكن عمل ذلك من خلال التنسيق الشرطي للأكسل لاحظ الصور صادر وارد شوقي.rar

السلام عليكم ورحمة الله وبركاته آثرت أن أفرد كل حقة في موضوع وكل حلقة ستكون ثلاثة أجزاء إن شاء الله حتى لا يطول الموضوع ويتوه الأعضاء بين طيات السطور نستكمل الحديث عن المصفوفات ...ونتحدث اليوم عن المصفوفة ثنائية الأبعاد .. عشان نفهم شكل المصفوفة الثنائية ..تخيل ورقة عمل يكون اتجاهها من الشمال لليمين ..طبق عملي عشان تفهم شكل المصفوفة كويس .. افتح ملف إكسيل وخلي ورقة العمل اتجاهها من الشمال لليمين من خلال التبويب Page Layout ثم الأيقونة Sheet Right-to-Left وضع بعض البيانات في الخلايا بالشكل التالي : A1= 10 B1=20 A2=30 B2=40 A3=50 B3=60 أنا تعمدت إنك تكتب القيم بالترتيب ده لأن هو ده اللي المصفوفة بتشوفه .. يعني نفس الترتيب ده هيكون داخل المصفوفة ، بمعنى آخر المصفوفة بتبدأ تشوف القيم الموجودة ابتداءً من اليسار أول خلية A1 وبعدين تمشي في الصف ولما الصف يخلص تروح للصف التالي يعني على شكل زجزاج ..ارسم الاتجاهات هتلاقي المصفوفة بتمشي على زجزاج .. نشوف الكود عشان نتأكد أكتر من صحة الكلام ده Sub TwoDimensionalArray() Dim Arr Arr = Range("A1:B3") End Sub نكتب السطرين دول .. نظهر نافذة Locals عشان نشوف عناصر المصفوفة ونشوف القيم لكل عنصر ضع مؤشر الماوس في أي مكان داخل الماكرو ادعس F8 3 مرات ، وشوف النافذة .. اضغط على علامة الزائد عشان تشوف شكل المصفوفة الثنائية (ذات البعدين) هنلاقي 3 أبعاد (دا البعد الأول ..اللي هو بعد الصفوف) Arr(1) Arr(2) Arr(3) بجانب كل بعد من أبعاد الصفوف علامة زائد ..لو فتحنا علامة الزائد الأولى هنلاقي الشكل ده Arr(1,1) Arr(1,2) ركز في شكل العنصر ...دلوقتي المحرر بيشوف البعد الأول بشكل مستقل (بعد الصفوف يعني بيتعامل مع الصفوف أولاً ...الصف في المقام الأول) ..بعد ما سيادته يشوف الصفوف يبدأ في عملية تشريح الصف عمود عمود ويجلب كل قيمة في العمود .. فلما فتحنا الجزء الخاص بالصف الأول لقينا Arr(1,1) يعني الصف الأول العمود الأول يعني A1 ... وقيمته تساوي 10 وفي نفس الصف انتقل للعمود الثاني Arr(1,2) يعني الصف الأول العمود الثاني ..يعني B1 وقيمته تساوي 20 ... بعد الانتهاء من جميع الأعمدة في الصف الأول يبدأ ينتقل للصف الثاني .. ومن الصف الثاني يبدأ يتعامل مع كل عمود وهكذا وهكذا وهكذا أرجو أن تكون وصلت المعلومة بشكل جيد لأن فهمك لطبيعة المصفوفة هيسهل عليك فهم أي معلومة أخرى ************** ننتقل لجزئية جديدة ألا وهي أول رقم في الفهرس وآخر رقم ..أعتقد ممكن تعرفوها بسهولة أول رقم في الفهرس وآخر رقم من خلال كلمة LBound وكلمة Ubound زي ما اتعملنا قبل كدا أضف السطرين للكود السابق Sub TwoDimensionalArray() Dim Arr Arr = Range("A1:B3") MsgBox LBound(Arr) MsgBox UBound(Arr) End Sub نفذ الماكرو هتلاقي أول رقم 1 وآخر رقم 3 (دا أول صف وآخر صف )) صحيح ... نعم صحيح معنى الكلام ده إن هو بيجيب أول وآخر رقم للبعد الأول بعد الصفوف ...طيب إحنا عندنا دلوقتي بعد ثاني اللي هو بعد الأعمدة .. دا ملوش لازمة ولا مهم ؟! أكيد مهم ...وعشان نعرفه يبقا لازم هنا في التعامل مع المصفوفات ثنائية الأبعاد نكون محددين أكتر ونحدد البعد اللي إحنا عايزينه في المثال السابق ممكن نعدل تعديل بسيط عشان نفهم النقطة دي Sub TwoDimensionalArray() Dim Arr Arr = Range("A1:B3") MsgBox LBound(Arr, 1) MsgBox UBound(Arr, 1) End Sub عملنا ايه أضفنا رقم 1 ودا بيمثل البعد الأول ..وبالتالي نحصل على نفس النتائج أول رقم 1 وآخر رقم 3 نفهم من كدا إن محرر الاكواد بيفهم إنك لو تركت الرقم 1 من غير ما تكتبه يبقا نفس الكلام لو كتبته (يبقا الافتراضي إنه بيتعامل مع البعد الأول ..معلش اعذروه إنه بيفضل البعد الأول ..وتقريباً بيفضل البعد الأول بعد الصفوف لأن الصفوف فيها كتير من حروف المصفوفة (الحر عمل عمايله مع دماغي)) أظن كدا فهمنا إننا لو عايزين نعرف أول رقم وآخر رقم في البعد الثاني هنستبدل رقم 1 برقم 2 Sub TwoDimensionalArray() Dim Arr Arr = Range("A1:B3") MsgBox LBound(Arr, 2) MsgBox UBound(Arr, 2) End Sub هتلاقي النتائج 1 و 2 يعني أول رقم في البعد الثاني بعد الأعمدة هو 1 (العمود الأول) ، وآخر رقم في البعد الثاني هو 2 (العمود الثاني) مما سبق : يمكن معرفة طول المصفوفة وعرضها جرب الكود التالي Sub TwoDimensionalArray() Dim Arr Arr = Range("A1:B3") MsgBox "طول المصفوفة أي عدد الأسطر أو الصفوف بها " & UBound(Arr, 1) MsgBox "عرض المصفوفة أي عدد الأعمدة بها " & UBound(Arr, 2) End Sub اعتمدنا هنا على كلمة UBound لأنها بتجيب من الآخر ..فبتجيب في السطر الأول عدد أسطر أو صفوف المصفوفة ، وفي السطر الثاني بتجيب عدد الأعمدة .. طيب : لونظرنا نظرة تفحص لشكل النطاق (اللي هو شبه شكل المصفوفة ) هنلاقيه على شكل مربع أو مستطيل .. وعشان نعرف عدد عناصر أو عدد خلايا النطاق نعمل ايه يا ترى ..بنضرب الطول × العرض عشان يديني المساحة (فين بتوع الرياضيات !!) طيب الطول في المثال السابق 3 (عدد الصفوف) ، والعرض يساوي 2 (عدد الأعمدة) يبقا معنى الكلام ده إن عدد عناصر المصفوفة يساوي = 3 × 2 = 6 عناصر أضف السطر التالي في نهاية الكود السابق MsgBox "عدد عناصر المصفوفة أي حجمها يساوي " & UBound(Arr, 1) * UBound(Arr, 2) آخر نقطة هنتكلم فيها .. استبدل هذا السطر في الكود Arr = Range("A1:B3") إلى هذا السطر Arr = Range(Cells(1, 1), Cells(3, 2)) ركز في الجزء ده : Cells(3, 2) طبعاً دي طريقة تانية لتحديد النطاق إننا بنستخدم كلمة Cells يليها رقم الصف ورقم العمود ، ولما نستخدمها بالشكل ده مع كلمة Range معناها نقطة البداية للنطاق (اللي هو A1) ، والجزء التاني نقطة النهاية (اللي هو (B3) ركز مع آخر خلية في النطاق هتلاقي رقم 3 يمثل آخر صف ، ورقم 2 يمثل رقم آخرعمود (أظن كدا وضحت) يعني طول المصفوفة وعرضها بنقدر نحدده من خلال آخر عنصر أو آخر خلية نكتفي بهذا القدر حتى لا يفقد الموضوع أهميته وإلى لقاء آخر متجدد بإذن الله

إليك التعديل التالي Private Sub CommandButton1_Click() Dim LColor On Error GoTo Error If TextBox1 = "" Then MsgBox ("أدخل نص في حقل البحث") Else Cells.Find(What:=TextBox1, After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate LColor = ActiveCell.Interior.Color ActiveCell.Interior.Color = vbYellow Application.Wait (Now + TimeValue("0:00:01")) ActiveCell.Interior.Color = LColor End If Exit Sub Error: MsgBox ("لا تتوفر نتائج للبحث") End Sub

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

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

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

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

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

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

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

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

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

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

السلام عليكم ورحمة الله وبركاته إخوتي الكرام /أخي الكريم محمد طاهر جعل الله لك من اسماً حظاً وافراً لكل أمر جوانب سلبية وإيجابية وكل منا له حسنات وسيئات فإن كان أحدنا محسناً فسيقول :هاؤم اقرؤوا كتابيه...وإن كان بخلاف ذلك فسيقول ياليتني لم أوت كتابيه....أردت من خلال هذا السياق القول أنه كان لنا وبشكل عملي الستايل السابق يمثل الحسنات بالمجمل فكل ما كنا نريده نجده .فإن كان هذا بنسخته متطوراً أكثر فنرجوا أن تأخذوا من ذلك الستايل كل مزاياه التي كان يتحلى بها وأنتم تعرفونها أكثر من غيركم..مثل رقم المشاركة..اسم المعجب.. عدد المشاهدات ...مما يحسسنا أننا أسرة واحدة في أماكن كتفرقة يشتاق كل منا للآخر..وهلم جرا... راجياً لكم التوفيق وسعادة الدارين ...تقبلوا تحياتي....السلام عليكم ورحمة الله وبركاته.

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

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

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

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

أستاذي العزيز القدير / ياسر خليل جزاك الله خير ماشاء الله عطاء مستمر ونهر لا ينضب وخفة دم وروح وأخلاق عالية تقبل إحترامي وتقديري وحبي لكم الله يحفظكم ويزيدكم علما ورفعة

أخي الكريم يرجى تغيير اسم الظهور للغة العربية بالنسبة للمبلغ الكلي والمدفوع .. لأني لا أقهم في المحاسبة ؟ هل تقصد عمود الدائن والمدين ؟ أم أن لها حساب خاص بها

السلام عليكم أ.khalid2117 ولما النقل واللصق ؟؟؟؟ لان الدالة VLOOKUP لا تبحث الى الوراء - بشكل ادق - تشترط ان يكون عمود الشرط هو العمود الاول اليس كذلك !! ولكن هناك العديد من الطرق للتغلب على ذلك وهى استخدام Choose لعمل جدول افتراضى عمودة الاول هو عمود الشرط =VLOOKUP($C11;CHOOSE({1,2};$BE$1:$BE$500;$BC$1:$BC$500);2;0) بل ايضاً الدالة IF يمكنها القيام بهذه اللوظيفة ( خلق الجدول الافتراضى ) =IFERROR(IF(C11<>"";VLOOKUP(C11;IF({1,0};BE1:BE200;BC1:BC200);2;0);"");"") تقبلوا خالص تحياتى

تفضل اخى الكريم المطلوب بالمرفق .. ان كان ما تريد لا تنسى ان تحدد الموضوع كمجاب لمن يهمه الامر 2- 2016_2.rar

عذراً على التأخير أنقل بينات العمود BC والصقها في BH وغير الدالة إلى =IFERROR(IF(C11="";"";VLOOKUP($C11;$BE$1:$BG$118;4;0));"")

السلام عليكم تفضل المرفق max-min-2.rar

أخي الكريم أشرف إليك الكود التالي عله يفي بالغرض Sub ConvertFormulaVBA() Dim LR As Long LR = Cells(Rows.Count, "D").End(xlUp).Row With Range("R8:R" & LR) .Formula = "=(T8*V8)/U8" .Value = .Value End With With Range("S8:S" & LR) .FormulaArray = "=Wish(D8:R27,X12:Y23,3,14,15,10)" .Value = .Value End With End Sub

جرب الكود التالي ..أدرج موديول جديد وضع فيه الكود التالي Private Type POINTAPI X As Long Y As Long End Type Private Type MOUSEHOOKSTRUCT pt As POINTAPI hwnd As Long wHitTestCode As Long dwExtraInfo As Long End Type Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long Private Const WH_MOUSE_LL As Long = 14 Private Const WM_MOUSEWHEEL As Long = &H20A Private Const HC_ACTION As Long = 0 Private Const GWL_HINSTANCE As Long = (-6) Private Const WM_KEYDOWN As Long = &H100 Private Const WM_KEYUP As Long = &H101 Private Const VK_UP As Long = &H26 Private Const VK_DOWN As Long = &H28 Private Const WM_LBUTTONDOWN As Long = &H201 Private mLngMouseHook As Long Private mListBoxHwnd As Long Private mbHook As Boolean Sub HookListBoxScroll() Dim lngAppInst As Long Dim hwndUnderCursor As Long Dim tPT As POINTAPI GetCursorPos tPT hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y) If mListBoxHwnd <> hwndUnderCursor Then UnhookListBoxScroll mListBoxHwnd = hwndUnderCursor lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE) PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0& If Not mbHook Then mLngMouseHook = SetWindowsHookEx( _ WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0) mbHook = mLngMouseHook <> 0 End If End If End Sub Sub UnhookListBoxScroll() If mbHook Then UnhookWindowsHookEx mLngMouseHook mLngMouseHook = 0 mListBoxHwnd = 0 mbHook = False End If End Sub Private Function MouseProc( _ ByVal nCode As Long, ByVal wParam As Long, _ ByRef lParam As MOUSEHOOKSTRUCT) As Long On Error GoTo errH If (nCode = HC_ACTION) Then If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then If wParam = WM_MOUSEWHEEL Then MouseProc = True If lParam.hwnd > 0 Then PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0 Else PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0 End If PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0 Exit Function End If Else UnhookListBoxScroll End If End If MouseProc = CallNextHookEx( _ mLngMouseHook, nCode, wParam, ByVal lParam) Exit Function errH: UnhookListBoxScroll End Function ثم في حدث الفورم أضف الكود التالي Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) HookListBoxScroll End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) UnhookListBoxScroll End Sub

النقطة الثانية هي : انه يوجد لدينا في الشيت (h) شرائح الحوافز والمكافئات للموظفين (المسوقين) والمشرفين وهي كالتالي المبيعات حافز/ المبيعات / الاسبوعي / لرفع الطلبات عدد الطلبات الحافز مكافئة المركز الاول 1 0 0 2 200 0 3 300 200 4 450 200 5 600 200 6 150 زيادة على السابق لكل طلب 150 المشرفين حافز/ مشرف المبيعات / الاسبوعي / لرفع الطلبات عدد الطلبات الحافز ملاحظات 5 500 6 600 7 750 9 1,000 >9 100 أضافة على السابق اريد توزيعها تلقائيا حسب الموظفين الذين يستحقونها في شيت ( الحوافز ) في الخلايا الفارغة وهي كالتالي . م اسم المسوق عدد الطلبات الحافز العمولة المكافأة الاجمالي 1 عبدالله 7 2 سعيد 12 3 احمد 11 4 رجب 1 5 المشرف 31 ----------------------------------------------------------------------------------------------- يفترض النتيجة تطلع معي على النحو التالي : م اسم المسوق عدد الطلبات الحافز العمولة المكافأة الاجمالي 1 عبدالله 7 900 900 2 سعيد 12 1,650 200 1,850 3 احمد 11 1,500 1,500 4 رجب 1 0 0 5 المشرف 31 3,200 3,200 واذا تساوت عدد الطلبات للمسوقين فإن كل واحد يأخذ 200 ريال مكافأة . أما أذا كان هناك فرق في العدد فالأكبر هو الذي يأخذ المكافئة . ولقد قمت بأرفاق الملف لكم ترحيل البيانات وتنسيق المرحل وحساب العدد للارسال.rar علما انني اقصد ( الموظفين ) هم ( المبيعات ) هم ( المسوقين ) والمشرفين هم المشرفين

أخي العزيز ما رأيك في فلترة البيانات في ورقة أخرى عن طريق التضفية المتقدمة طبعا قمت ببعض التعديلات في عناوين الجدول فقد ألغيت دمج الخلايا المدمجة لأن الدمج يعيق عمل الأكواد وترقيم العناوين المتشابهة حتى لا يكرر الكود نتائج العنوان الأول في بقية العناوين المشابهة له اذهب إلى ورقة (Sheet2 (2 وستجد بأعلى الصفخة معايير للفلترة والبحث باللون الأصفر قم بتعبئتها بما تريد ليتم البحث على أساسها كما أن هناك الصف الثالث مخفي هو أساس المعيار للبحث ولكنه يجلب بياناته من الصف الرابع فتم إخفائه لاحتوائه على معادلات خاصة بالتاريخ حتى لا يتم حذفها عن طريق الخطأ المهم لاحظ المرفق إن شاء الله يكون هو المطلوب أم إذا أردت الفلترة في نفس الورقة فقم بعملية الفلترة التي يوفرها برنامج الأكسل فقط معادلات الجمع في آخر الجدول تحتاج تعديل ليتم جمع البيانات المفلترة فقط هذا والله الموفق Utility customs Follow-up 1 (Autosaved) (1).rar

وعليكم السلام ورحمة الله وبركاته أخي الحبيب عبد العزيز مشكور على مرورك العطر وإن شاء الله معاً سوياً خطوة بخطوة لفهم المصفوفات حيث أن هذا الموضوع هام جداً ومفيد للغاية في التعامل مع الأكواد .. الأخ الغالي إبراهيم أبو ليلة عوداً حميداً .. اشتقنا لك ولمشاركاتك القيمة وتسلم على الأداء العالي والمميز وبالمناسبة سأسأل سؤال متقدم على الشرح ... كيف نضع قيم المصفوفة في النطاق A1:G1 أي وضعها في الصف الأول لتكون القيمة sat في الخلية A1 وتكون القيمة sun في الخلية B1 وهكذا للقيم السبعة للمصفوفة ؟

السلام عليكم انا اسمي موجود اشكرك على الموضوع ، وعلى وجود اسمي بين اخواني العمالقة جعفر

تابع الدرس الثانى ندخل الى مرحله تنفيذ الماكرو الذى قمنا بتسجيله ولها خطوات معينة كالتالى : نذهب الى الشيت ثم نضغط على Insert تظهر لنا نافذة نختار منها Button ثم نقوم بوضعه داخل الشيت كما بالصور التالية ثم نقوم بالضغط على الزر كليك يمين ونختار تعيين ماكرو كالتالى تظهر لنا نافذة نختر منها اسم الماكرو وهنا قد اسميته MZM_ELSHRIEF ثم نختار This Workbook ثم نضغط على OK كالتالى الآن يمكنك تنفيذ الماكرو الذى قمنا بتسجيله بمجرد الضغط على الزر أى Button يمكنك أيضا تغيير اسم الزر اذا اردت ذلك كالتالى بالضغط كليك يمين على الزر تظهر لك نافذة اختر منها اضافة نص حفظ الملف عند حفظ الملف تظهر لنا رساله كما بالصورة التالية نضغط على زر NO فتظهر لنا رساله أخرى كما بالصورة التالية نضغط على زر Yes فتظهر لنا نافذة كما بالصورة التالية نقوم بإختيار من Save as type Excel Macro-Enbled Workbook ثم نضغط على Save الخيار التالى كما بالصورة التالية فتكون أيقونه الملف كما بالصورة التالية انتهى الدرس الثانى مرفق ملف PDF به كامل الدرس الثانى يرجى فى حاله هناك استفسار أن يكون فى مضمون الدرس حتى لا يتم التشتيت وتقبلوا منى وافر الاحترام والتقدير الدرس 2.rar

استاذ على انا بخير وحضرتك يا ريت تكون بخير وبسلام وشكرا عل سؤالك وبعتزر عن عدم توجدى باستمرار والكود الموجود لم يعطينى نتيجة لان الملفات تظل مفتوحة ولم تغلق سكر استاذ على

السلام عليكم =========== بارك الله فيك اخى ايسم وحشنى اخى خالد دايما بخير حفظك ربى الاخ bousara اذا كنت تريد اظهار المكرر والتعامل معه عليك بالمرفق للاستاذ خبور فحص المكرر.rar

يوجد لدى ملف كبير به 45 الف عامل اريد فى ورقة اخرى احضار الصف الذى به رقم الملف ثم التعديل فيه ثم اعادته مرة اخرى وجزاكم الله خيرا مرفق ملف ابو عمر بيانات العاملين.rar

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

ماقصرت اخوي سمير الله يسعد ايامك ويوفقك دنيا واخره واسف اذا اشغلتك معي

السلام عليكم ورحمة الله وبركاته اخي الكريم الوافي عذرا" للتاخير لانشغالي يوم السبت اما يوم الاحد لدي عطلة فلم استطع العمل على الكمبيوتر هذان المرفقان شرح لطريقة عمل قائمة منسدلة وملفك الذي تم التعديل عليه لك تحياتي اخوك سمير نجار السلام عليكم ________________.rar _______11.rar

وين رحتوا يااخوان

ياليت اخوي يكون التعديل على الملف المرفق ويكون بنفس التنسيق لاني قمت بتغيير التنسيق لكن للاسف القائمة المنسدله في خانة الرمز لم تعد تعمل ارجو اضافة قائمة منسدله للرتبه وحل مشكله القائمة المنسدله في الرمز ولك الشكر وخالص التقدير _______11.rar

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

السلام عليكم هذه اول مشاركة لى ارجو ان تنول رضاكم هذا ملف لحساب المرتبات الشهرية يشمل حساب التامينات الاجتماعية والضارئب على القانون المصرى وبه ترحيل الى التسوية السنوية لاعادة حساب الضريبة سنويا ملحوظة: تعديل الاسماء والوظائف فى كشف التسوية السنوة (اخر كشف) يمكن التعديل فى الخانات الصفراء فقط الملف محمى بدون كلمة سر Salary.rar

السلام عليكم ورحمة الله وبركاتة ,, لو تكرمتوا ياجماعة ماهي طريقة إضافة قائمة منسدلة مثل الموجود في الصورة فوق يبدو أنها بسيطة ولكن للأسف ماعرفت ,, جزاكم الله خير ووفقكم

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