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

المشكلة اني لا اعرف اسم الاعدادات بالعربي غير عرض الاعمدة الى 0 ; 1.27 ; 0 جعفر

وعليكم السلام هاي سهله ضبط الحقل هكذا: وانسخ القيمة (القيمة في الصورة مقلوبة بسبب الكتابة بالعربي): صواب;True;-1;خطأ;False;0 جعفر

المعادلة المطلوبة IF(C2="","",VLOOKUP(C2,{0,0.25;500000,0.3;750000,0.35},2)*C2)=

يجب علي ماكرو المسح في صفجة بيانات الطلا ب ان لا ينفذ الا على هذه الصفخة بالذات لذلك تداركاً للخطأ يجل علينا وضع سطر في الكود If ActiveSheet.Name <> "بيانات الطلاب" Then Exit Sub ليصيح الكود هكذا Sub ClearConstantsOnly() 'كود مسح البيانات و الحفاظ على المعادلات If ActiveSheet.Name <> "بيانات الطلاب" Then Exit Sub prompt = "هل حقا تريد مسح كل البيانات!؟" Command_buttons = vbYesNo + VbMsgBoxRt1Reading Title = "تحذير. انتبه !!!!" project = MsgBox(prompt, Command_buttons, Title) If project = vbYes Then On Error Resume Next Range("c17:g516").SpecialCells(xlCellTypeConstants).ClearContents Range("A1").Select End If End Sub

لم تذكر شكل النتائج المتوقعة كما طلبت منك عموماً جرب الكود بهذا الشكل Option Explicit Sub ImportDataFromClosedWBs_YasserKhalil() Dim strFolder As String Dim strFile As String Dim wbk As Workbook Dim sh As Worksheet Dim lr As Long Dim i As Long With Application .ScreenUpdating = False .Calculation = xlManual .DisplayAlerts = False .AskToUpdateLinks = False End With strFolder = ThisWorkbook.Path & "\الفواتير\" strFile = Dir(strFolder & "*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open(strFolder & strFile) Set sh = wbk.Worksheets(1) With ThisWorkbook.Worksheets(1) i = 7 lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value Do .Range("A" & lr).Resize(1, 6).Value = sh.Range("A" & i).Resize(1, 6).Value lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) i = i + 1 Loop Until sh.Range("A" & i).Value = "" End With wbk.Close False strFile = Dir Loop With Application .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub

هلا والله أخوي عبدالفتاح

وعليكم السلام اخي عبدالفتاح مافي داعي للكود من اصله اضف هذا الحقل الى الاستعلام Q_all ، ليحسب عدد حصص المدرسين: sthu88: Nz([sun1]/[sun1],0)+Nz([sun2]/[sun2],0)+Nz([sun3]/[sun3],0)+Nz([sun4]/[sun4],0)+Nz([sun5]/[sun5],0)+Nz([sun6]/[sun6],0)+Nz([sun7]/[sun7],0)+Nz([sun8]/[sun8],0)+Nz([sun9]/[sun9],0)+Nz([mon1]/[mon1],0)+Nz([mon2]/[mon2],0)+Nz([mon3]/[mon3],0)+Nz([mon4]/[mon4],0)+Nz([mon5]/[mon5],0)+Nz([mon6]/[mon6],0)+Nz([mon7]/[mon7],0)+Nz([mon8]/[mon8],0)+Nz([mon9]/[mon9],0)+Nz([tu1]/[tu1],0)+Nz([tu2]/[tu2],0)+Nz([tu3]/[tu3],0)+Nz([tu4]/[tu4],0)+Nz([tu5]/[tu5],0)+Nz([tu6]/[tu6],0)+Nz([tu7]/[tu7],0)+Nz([tu8]/[tu8],0)+Nz([tu9]/[tu9],0)+Nz([wed1]/[wed1],0)+Nz([wed2]/[wed2],0)+Nz([wed3]/[wed3],0)+Nz([wed4]/[wed4],0)+Nz([wed5]/[wed5],0)+Nz([wed6]/[wed6],0)+Nz([wed7]/[wed7],0)+Nz([wed8]/[wed8],0)+Nz([wed9]/[wed9],0)+Nz([thu1]/[thu1],0)+Nz([thu2]/[thu2],0)+Nz([thu3]/[thu3],0)+Nz([thu4]/[thu4],0)+Nz([thu5]/[thu5],0)+Nz([thu6]/[thu6],0)+Nz([thu7]/[thu7],0)+Nz([thu8]/[thu8],0)+Nz([thu9]/[thu9],0) وفي التقرير: اجعل مصدر بيانات الحقل sthu88 تشير الى حقل الاستعلام sthu88 ، واما حقل total ، فاجعل مصدره: =Sum([sthu88]) جعفر

ربما ينفع هذا الكود Option Explicit Sub Tarhil() Dim First, Sec As Worksheet Dim m, n, x As Long Set First = Sheets("تسجيل الدرجات") Set Sec = Sheets("دور ثاني") m = 11 Application.ScreenUpdating = False For n = 6 To 154 x = 2 * n - 1: Sec.Range("E" & x & ":CT" & x).ClearContents Next For n = 8 To x - 2 If First.Cells(n, 3) = "راسب" Then Sec.Range("E" & m).Resize(1, 95).Value = First.Range("D" & n).Resize(1, 95).Value m = m + 2 End If Next Application.ScreenUpdating = True MsgBox ("That Is All ") End Sub

استاذن من استاذنا جعفر

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

السلام عليكم جرب التعديل التالي عله يفي بالغرض Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim r As Long Dim m As Long Set ws = Sheets("تسجيل الدرجات") Set sh = Sheets("دور ثاني") m = 11 Application.ScreenUpdating = False For r = 11 To 307 Step 2 sh.Range("E" & r & ":CT" & r).ClearContents Next r For r = 8 To 306 If ws.Cells(r, 3) = "راسب" Then sh.Range("E" & m).Resize(1, 95).Value = ws.Range("D" & r).Resize(1, 95).Value m = m + 2 End If Next r Application.ScreenUpdating = True MsgBox ("الحمد لله تـــم الترحيل ") End Sub

ليس هذا الموضع الذي قصدته .. انظر بالأعلى قليلاً ستجد جملة End With أخرى قبلها ...

تفضل المرفق بعد التعديل 660.1.Test2006.mdb.zip

المنبه لايزال موجودا ، ويعتمد على نوع المتصفح الذي تستعمله ، انا استخدم Chrome وشغال التنبيه تمام جعفر

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

أخي شفان اذا تشوف طريقتي ، فانا عملت التالي: 1. جعلت 3 اختيارات لكل سطر ، فاصبحت الاختيارات سطرين: السطر الاول: صواب ثم True ثم -1 السطر الثاني: خطأ ثم False ثم 0 2. جعلت الحقل يأخذ قيمته من القيمة الاخيرة -1 او 0 (العمود رقم 3) ، وبهذه الطريقة تفاديت عمل اي تغيير في الكود جعفر

اتفضل استخدمت كومبوبوكس مع مربع نصي واستخدمت هذا الكود Private Sub Combo16_AfterUpdate() If Me.Combo16 = "صواب" Or Me.Combo16 = "true" Or Me.Combo16 = "-1" Then Me.on_or_of = -1 ElseIf Me.Combo16 = "خطا" Or Me.Combo16 = "false" Or Me.Combo16 = "0" Then Me.on_or_of = 0 Else Me.on_or_of = "" End If Me.TestF.Form.Requery Me.Refresh End Sub 660.Test2006.rar

جرب نقل الأسطر التالية إلى قبل جملة End With .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value

وعليكم السلام وكل عام وأنت بخير أخي الكريم الملف المرفق يجب أن يكون معبر عن الملف الأصلي تماماً لكي يكون الكود مناسب للموضوع .. أمر آخر يرجى عدم اقتباس الأكواد في الردود لكي لا يطول الموضوع بدون داعي جرب الكود التالي عله يفي بالغرض إن شاء الله Option Explicit Sub ImportDataFromClosedWBs_YasserKhalil() Dim strFolder As String Dim strFile As String Dim wbk As Workbook Dim sh As Worksheet Dim lr As Long Dim i As Long With Application .ScreenUpdating = False .Calculation = xlManual .DisplayAlerts = False .AskToUpdateLinks = False End With strFolder = ThisWorkbook.Path & "\الفواتير\" strFile = Dir(strFolder & "*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open(strFolder & strFile) Set sh = wbk.Worksheets(1) With ThisWorkbook.Worksheets(1) i = 7 Do lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("A" & lr).Resize(1, 6).Value = sh.Range("A" & i).Resize(1, 6).Value .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value i = i + 1 Loop Until sh.Range("A" & i).Value = "" End With wbk.Close False strFile = Dir Loop With Application .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub

طريق لغه البرمجه VBA - اين انت منه ؟ فارق السرعات بين التعامل مع خلايا ورقة العمل والمصفوفات رابط الجزء الاول من سلسله من اين ابدأ -انتظروا الجزء الثاني من هذه السلسله قريباً ان شاء الله - المرفقات VBA Road.rar

تم إضافة زر للحفظ التلقائى والخروج مباشرة برنامج قوائم الفصول.rar

انسخ هذا المعادلة الى الخلية B1 واسجب نزولاً =IF(A1="","",VLOOKUP(A1,{1,1425;250,1400;490,1350;750,1300;1000,1290},2)) و اذا لم تضبط معك استبدل الفاصلة "," بفاصلة منقوطة ";" في المعادلة أو العكس(حسب اعدادات الجهاز عندك ) لتصبح هكذا =IF(A1="";"";VLOOKUP(A1;{1,1425;250,1400;490,1350;750,1300;1000,1290};2))

كود اخر بواسطة Loop انتبه الى الملاحظات في اسفل الكود بواسطة هذه المعادلات لا تتأثر الخلايا في حال زيادة صفوف او حذف صفوف (قبل الصف 12)من الورقة أو اذا تم حذف اي اسم من لائحة الفصل لا يتأثر الترقيم في كلا العامودين اذا كنت قد فهمت الكود اليك هذا المهمة تنزيل كود اخر بحيث: 1-يعمل على المتغير I بواسطة Loop (من 1 الى 10) * عدد الفصول 2-يعمل على المتغير K بواسطة Loop (من 17 الى اخر صف في الورقة Main) * هذا الخاصية موجودة في الكود المرفق 3- يقوم بترقيم التلاميد بدون معادلات في العامودين I & C في كل ورقة من ورقات الصفوف Option Explicit Sub tanslate_data_salim_loop() Dim My_Sh As Worksheet Dim lr1, i, k, m, col, y As Integer Dim my_rg, cel As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lr1 = Main.Cells(Rows.Count, "c").End(3).Row Set my_rg = Main.Range("c17:g" & lr1) For i = 1 To 10 m = 0 Set My_Sh = Sheets(i & "") My_Sh.Range("d12:g36").ClearContents My_Sh.Range("i12:l36").ClearContents k = 17 Do Until k = lr1 + 1 'يمكنك استعمال هذا السطر ' Do While k <= lr1 'او هذا السطر Select Case m Case Is < 25 col = m + 12 y = 4 Case Else col = m - 13 y = 9 End Select If Main.Cells(k, "g") = i Then My_Sh.Cells(col, y).Resize(1, 4).Value = Main.Cells(k, 3).Resize(1, 4).Value m = m + 1 End If k = k + 1 Loop Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ملاحظات ' بالنسبة للمعادلات في صفحات الصفوف 'الافضل كتابة هذه المعادلة في الخلية 'C12: '=IF(D12="","",MAX($C$11:C11)+1) 'ثم اسحب نزولاً 'و هذه المعادلة في الخلية 'I12: '=IF(I12="","",MAX(C:C)+ROWS($A$1:A1)) 'ثم اسحب نزول '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

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

660.Test2000.rar

660.Test2000.rar

تمام

السلام عليكم تقضل المرفق فيه معادلة صفيف (الخلية الملونة بالأصفر) - المعادلة بعد كتابتها يجب تأكيدها بواسطة CTRL+SHIFT+ENTER (وفي هذه الحالة تظهر المعادلة بين العلامتين {}) بدلا من تأكيدها بواسطو ENTER فقط... بن علية حاجي النسبه.rar

الحمدلله تم الوصول الى النتيجة انا عملت حقل جديد في الاستعلام بواسطة هذا s_nm1: DLookUp("[s_nm]";"ss";"[no]='" & [no] & "'") هو يبحث عن حقل s_nm في جدول ss بشرط ان يكون قيمة في حقل no في جدول يكون يساوي مع حقل no في استعلام ولان حقل no في جدول هو من نوع نصي لذلك اضفنا علامة (') و ("'") مع الشرط و اذا وصلت للجوابك ... اعمل علامة صح امام جواب الصحيح لكي من يمر هنا يعرف ما هو جواب لهذا السؤال تقبل تحياتي

وعليكم السلام وتأكيدا لما تقول ، وبإختصار: لا يمكن استعمال الاكسس بدون تنصيب الاكسس او Accsess RunTime. جعفر

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

اخي العزيز شاهد هذا البرنامج لعلة يفي بالغرض. مكتبةsama.rar