عبد الفتاح كيرة

شكرا سعادة المراقب العام سؤال : لماذا الضرب فى 2 ثم القسمة على 2 ؟

=CEILING(D4;0.5)

الله يبارك فيك جزاك الله خيرا أستاذ جمال

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

بارك الله فى أستاذنا بن عليه أول المبادرين لمساعدة الأعضاء بعد إذنك يمكن اختصار الكود شوية ؟ Sub Macro1() Dim Cell As Range, cel As Range On Error Resume Next Set MyRange = Sheets("æÑÞÉ1").Range("F10000", Range("F3").End(xlUp)) Application.ScreenUpdating = False For Each Cell In MyRange If Cell = "ØáÈ Êã ÊÓáíãå" Then maligne = Sheets("3").Range("A65536").End(xlUp).Row + 1 Rows(Cell.Row).Cut Worksheets("3").Range("A" & maligne) End If Next Application.ScreenUpdating = True End Sub و للإفادة : يمكن استخدام أمر القص و اللصق فى سطر واحد لكن يجب عمل كود لحذف الأسطر المقطوعة وذلك بتحديد مكان اللصق مباشرة بعد مكان القص ( وينطبق نفس الكلام على أمر copy إلا أن الخلايا المنسوخة تبقى مكانها ) ( Rows(Cell.Row).Cut Worksheets("3").Range("A" & maligne) مع الشكر الجزيل

شكرا لك أستاذ ياسر بارك الله فيك

و ضح المطلوب أكثر أخ طاهر

السلام عليكم شكرا للأخ tofimoon4 والحمد لله أن نلت ما تريد = الأخ الأستاذ جمال رقم العمود رقم مربع النص ربطنا الإثنين بقيمة المتغير i أما لو كان رقم العمود كل خطوتين فنفذ الآتى : سنضع متغيرا جديدا لقيمة رقم العمود قبل الحلقة و سيكون 2 مثلا k = 2 ثم من داخل الحلقة نزيده k=k+2 آثرت ذكر أحد الحلول نظريا كى تشاركنى التوصل للكود النهائي ننتظر الإبداعات وشكرا لثنائك الطيب الذى هو أكثر مما أستحق هذا تعديل للكود فى حالة وجود أعمدة فارغة Dim k As Integer k = 3 On Error Resume Next For i = 3 To 8 Me.Controls("TextBox" & i).Text = Application.WorksheetFunction _ .VLookup(ComboBox1.Value, Sheets(1).Range("b7:n700"), k, 0) k = k + 2 Next i DataBase1-kemas2.rar

فورم لاستعراض قاعدة بيانات كود : On Error Resume Next For i = 3 To 8 Me.Controls("TextBox" & i).Text = Application.WorksheetFunction.VLookup(ComboBox1.Value, Sheets(1).Range("b7:n700"), i - 1, 0) Next i المرفقDataBase1-kemas.rar

فقط غير تنسيق الخلية ليظهر بها رقمان عشريان بزر الماوس الأيمن على الخلية و اختيار تنسيق خلايا من القائمة وزد عدد الأرقام العشرية

شكرا لك أستاذنا جزاك الله خيرا لا يوجد تحكم بعدد الطلاب بكل لجنة ؟

هناك صفحة أو كائن محذوف باسم main main1

شكرا لك أخى بارك الله فيك

معادلة للمجموع الأصلى =IF(F4="غ";"غ";F4*80/100)

احذف Unload Me

ضع المعادلة التالية فى المجموع الكلى =IF(AND(D2="غ";E2="غ");"غ";SUM(D2:E2)) موفق إن شاء الله

المطلوب يكتنفه الغموض لكن أنا عملت كود يعطى قائمة للأسر بدون تكرار طلعوا 542 أسرة لو هناك توزيع لصدقات اسم الأسرة يرد مرة واحدة Sub Macro3() ' ' Macro3 Macro ' Application.ScreenUpdating = False ' Range("b2:b1000").ClearContents Sheets("æÑÞÉ1").Range("B1:B786").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Sheets("æÑÞÉ1").Range("B1:B786"), CopyToRange:=Range("B1"), _ Unique:=True Range("b2").Select Application.ScreenUpdating = True End Sub قائمة بأسماء الأسر -kemas.rar

لا لابد من إعادة التطبيق للماكرو أو التصفية شكرا لك أخى new4a بارك الله فيك

جزاك الله خيرا شرح ممتاز أستاذ معتصم بالتوفيق و إلى الأمام

عليكم السلام و رحمة الله تعالى و بركاته بل الشكر لك على جهودك الواضحة فى المنتدى وفقك الله للخير وهذا هو المطلوب بدون معادلات حيث دمجت المعادلة فى الكود Sub Button1_Click() Dim myrng As Range, c1 As Range, i As Long Application.ScreenUpdating = False i = 4 Set myrng = Sheets(1).Range("b4:b100") For Each c1 In myrng If Application.WorksheetFunction.CountIf(Sheets("2").Range("b4:b100"), c1) = 0 Then c1.Resize(1, 3).Copy Sheets("3").Range("a" & i) i = i + 1 End If Next c1 Application.ScreenUpdating = True Set myrng = Nothing End Sub get-kemas2.rar

أشكرك بارك الله فيك

فى الشيت الأول سنضع معادلة لحساب مرات تكرار الاسم فى الشيت الثانى =COUNTIF('2'!$B$4:$B$100;'1'!B4) و فى الشيت الثالث سنضع زر مرتبط بماكرو يرحل الأسماء حسب نتيجة المعادلة السابقة صفر أو 1 Sub Button1_Click() Dim myrng As Range, c1 As Range, i As Long Application.ScreenUpdating = False i = 4 Set myrng = Sheets(1).Range("a4:a100") For Each c1 In myrng If c1 = 0 Then c1.Offset(0, 1).Resize(1, 10).Copy Sheets("3").Range("b" & i) i = i + 1 End If Next c1 Application.ScreenUpdating = True Set myrng = Nothing End Sub get-kemas.rar

عليكم السلام و رحمة الله تعالى و بركاته محرر فيجوال بيسك ملحق بجميع نسخ أوفيس بما فيها 2010 الوصول إليه من الشيت Alt+F11 أما تعلم VB فمن خلال متابعة مشكلات الإخوة هنا و حلول أعضاء المنتدى لها خطوة خطوة وعمل برامج بسيطة للتدريب و اكتساب الخبرة و سؤال الأعضاء فيما تتوقف عنده لى بعض شروح الفديو هنا متنوعة بين السهل و المتقدم http://www.youtube.com/user/MsKemas حوالى 60 فديو و إن شاء الله تكون من المحترفين

ما لفت انتباهى هو الطريقة الجدية البعيدة عن الهزار والدلع التى يحادث بها الرجل ابنه

سلمك البارى أستاذى الفاضل جمال جزاك الله خيرا