عبدالله بشير عبدالله

قمت بعمل مثال لك بفصل الحالات الثلاتة كما طلبت الكود Sub FilterValues() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row ws.Range("G2:H" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row).ClearContents ws.Range("I2:J" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row).ClearContents ws.Range("K2:L" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).ClearContents Dim negArr() As Variant Dim posArr() As Variant Dim zeroArr() As Variant Dim i As Long, negCount As Long, posCount As Long, zeroCount As Long Dim dataRange As Range Set dataRange = ws.Range("B2:C" & lastRow) Dim dataArr As Variant dataArr = dataRange.Value ReDim negArr(1 To UBound(dataArr, 1), 1 To 2) ReDim posArr(1 To UBound(dataArr, 1), 1 To 2) ReDim zeroArr(1 To UBound(dataArr, 1), 1 To 2) negCount = 0 posCount = 0 zeroCount = 0 For i = 1 To UBound(dataArr, 1) Select Case dataArr(i, 2) Case Is < 0 negCount = negCount + 1 negArr(negCount, 1) = dataArr(i, 1) negArr(negCount, 2) = dataArr(i, 2) Case Is > 0 posCount = posCount + 1 posArr(posCount, 1) = dataArr(i, 1) posArr(posCount, 2) = dataArr(i, 2) Case Else zeroCount = zeroCount + 1 zeroArr(zeroCount, 1) = dataArr(i, 1) zeroArr(zeroCount, 2) = dataArr(i, 2) End Select Next i ws.Range("G2").Resize(negCount, 2).Value = Application.Index(negArr, Evaluate("ROW(1:" & negCount & ")"), Array(1, 2)) ws.Range("I2").Resize(posCount, 2).Value = Application.Index(posArr, Evaluate("ROW(1:" & posCount & ")"), Array(1, 2)) ws.Range("K2").Resize(zeroCount, 2).Value = Application.Index(zeroArr, Evaluate("ROW(1:" & zeroCount & ")"), Array(1, 2)) End Sub الملف فصل الدائن والمدين والصفرية الى اعمدة جديدة.xlsb

السلام عليكم ورحمة الله وبركاته صباح الخير الاستاذ سعيد بما اننا في نفس العمر تقريبا 61 سنة واشتراكنا بالمنتدى تقريبا فى نفس السنة بفارق عام اهديك هذا الملف مع تحياتنا الخالصة لاخينا الاستاذ محمد هشام وادعو الله ان يمدكما بطول العمر ويمتعكما بالصحة وراحة البال والرزق الوفير بمكن كتابة تاريخ البدابة والتهاية يدوبا في L2 -N2 فتتم العملية الزر في الصفحة اخنياري ولبس اساسى مهمته انك تكتب تاربخ البداية بدويا ثم تكتب عدد الايام المراد اظافتها الى التاريخ في N3 ثم اضغط على الزر فبظفها الى تاريخ النهاية تحياتى لكما ولكل اخوتنا في هذا المنتدى انقسام الشهور على قائمتبن.xlsm

السلام عليكم اثراء للموضوع وتنوع الحلول وبعد اذن استاذنا الفاضل محمد هشام الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("L2:M2")) Is Nothing Then Dim startDate As Date Dim endDate As Date Dim currentDate As Date Dim outputRow As Long startDate = Me.Range("L2").Value endDate = Me.Range("M2").Value outputRow = 6 Me.Range("K6:L" & Me.Rows.Count).ClearContents For currentDate = startDate To endDate If Weekday(currentDate, vbSunday) <> 6 And Weekday(currentDate, vbSunday) <> 7 Then Me.Cells(outputRow, 11).Value = Format(currentDate, "dddd") Me.Cells(outputRow, 12).Value = currentDate outputRow = outputRow + 1 End If Next currentDate End If End Sub الملف تسلسل الأيام بدون أيام 2الجمعة والسبت.xlsm

السلام عليكم حقيقة كود الفاضل محمد هشام حاولت فهمه لم اتمكن من استيعابه بالكامل لانى حاولت التعدبل فيه بسبب الصورة المتحركة عند اختياره شهر 12 ظهر بالصورة بداية الشهر الاحد يوافق يوم 8 وحسب التقوبم الشهر يبدأ يوم 1 طبعا لم اجرب الملف كما قلت حسب الصورة المتحركة تأمل من استاذنا الفاضل تعدبل الكود للاستفاذة ربما التعديل التالى لاختيار التاريخ يناسبك بمكن تعديل السنوات من الكود أيام الشهر من يوم محدد - vba (1).xlsm

وعليكم السلام ورحمة الله وبركاته الاستاذ محمد هشام في المشاركة السابقة اخبرك (في حالة كنت تستخدم إصدار قديم لن تشتغل معك الصيغ. أخبرني بذالك لمحاولة إنشاء دالة أو كود vba ينفذ نفس المهمة) حسب ملفك الحالى كود في حدث الورقة كلما تم التغيير في M2 يتم التغيير في الاعمدة الملف أيام الشهر من يوم محدد - vba (1).xlsm

السلام عليكم بعد اذنكما محاولة حسب فهمى لطلبك فى الملف المرفق باول مشاركة عن طربق الكود في حدث الورقة الكود Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("C2")) Is Nothing Then Me.Range("A5:B" & Me.Rows.Count).ClearContents Dim monthYear As Date Dim firstDay As Date Dim lastDay As Date Dim currentDay As Date Dim outputRow As Long monthYear = Me.Range("C2").Value firstDay = DateSerial(Year(monthYear), Month(monthYear), 1) lastDay = DateSerial(Year(monthYear), Month(monthYear) + 1, 0) Dim startDay As Date startDay = firstDay Do While Weekday(startDay, vbSunday) <> vbSunday startDay = startDay + 1 Loop outputRow = 5 For currentDay = startDay To lastDay If Weekday(currentDay, vbSunday) <= 5 Then Me.Cells(outputRow, 2).Value = currentDay Select Case Weekday(currentDay, vbSunday) Case 1 Me.Cells(outputRow, 1).Value = "الأحد" Case 2 Me.Cells(outputRow, 1).Value = "الإثنين" Case 3 Me.Cells(outputRow, 1).Value = "الثلاثاء" Case 4 Me.Cells(outputRow, 1).Value = "الأربعاء" Case 5 Me.Cells(outputRow, 1).Value = "الخميس" End Select outputRow = outputRow + 1 End If Next currentDay End If End Sub الملف أيام الشهر من يوم محدد.xlsb

وعليكم السلام ورحمة الله وبركاته الكود Sub ExtractAbsentees() Dim ws As Worksheet Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim outputRow As Long Set ws = ThisWorkbook.Sheets("SHEET1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column outputRow = 5 For i = 5 To lastRow For j = 4 To lastCol If ws.Cells(i, j).Value = "A" Then ws.Cells(outputRow, 15).Value = ws.Cells(i, 2).Value ws.Cells(outputRow, 16).Value = ws.Cells(4, j).Value outputRow = outputRow + 1 End If Next j Next i End Sub الملف الغياب.xlsb

ما شاء الله استاذ محمد معادلة وكود . اثراء للموضوع المعادلة التالية تؤدى الى نفس النتيجة وهى تستخدم دالة AGGREGATE لتحديد آخر عمود يحتوي على قيمة غير فارغة، ومن ثم دالة INDEX لاسترجاع القيمة المطابقة. المعاداة =IFERROR( IF(A14=""; ""; INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); AGGREGATE(14; 6; COLUMN($B$2:$E$2) / (INDEX($B$2:$E$9; MATCH(A14; $A$2:$A$9; 0); 0)<>""); 1) - COLUMN($B$2) + 1) ); "بدون نتيجة") الملف اخر ادخال بالصف.xlsx

السلام عليكم اذاكانت الملفات المرتبطة عددها بسيط استخدم الطريقة اليدوية التالية فتح الملف الرئيسي: افتح ملف Excel الرئيسي الذي يحتوي على الروابط إلى الملفات الأخرى. تحرير الروابط: اذهب إلى علامة التبويب "البيانات" (Data) في الشريط. اضغط على "تحرير الروابط" (Edit Links) التي توجد عادة في مجموعة "الاتصالات" (Connections). تغيير مصدر الروابط: ستظهر لك نافذة تحتوي على جميع الروابط الموجودة في الملف. حدد الروابط التي تحتاج إلى تحديث، ثم اضغط على "تغيير المصدر" (Change Source). اختيار الموقع الجديد: اختر الملفات من الموقع الجديد الذي تم نقلها إليه. تحديث الروابط: بعد اختيار الملفات، اضغط على "موافق" لتحديث الروابط إلى الموقع الجديد. اذ كانت الروابط كثيرة فاستخدم الكود التالى Sub UpdateLinks() Dim OldLink As String Dim NewLink As String Dim LinkArray As Variant Dim i As Integer ' الرابط القديم OldLink = "C:\المسار_القديم\" ' الرابط الجديد NewLink = "C:\المسار_الجديد\" LinkArray = ActiveWorkbook.LinkSources(Type:=xlExcelLinks) If Not IsEmpty(LinkArray) Then For i = LBound(LinkArray) To UBound(LinkArray) If InStr(LinkArray(i), OldLink) > 0 Then ActiveWorkbook.ChangeLink Name:=LinkArray(i), NewName:=Replace(LinkArray(i), OldLink, NewLink), Type:=xlExcelLinks End If Next i End If MsgBox "تم تحديث الروابط بنجاح!", vbInformation End Sub قم بتعديل المسارات (OldLink و NewLink) حسب الموقع القديم والجديد للملفات.

المعادلة =IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف تحقق التارحت.xlsx

الكود يرتب ابجدي ويحذف التكرار Private Sub UserForm_Initialize() Dim ws As Worksheet Dim rng As Range Dim data As Variant Dim sortedData As Variant Dim uniqueData As Collection Dim i As Long, j As Long Dim temp As Variant Set ws = ThisWorkbook.Sheets("Sheet3") Set rng = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) data = rng.Value ReDim sortedData(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) sortedData(i, 1) = data(i, 1) Next i For i = 1 To UBound(sortedData, 1) - 1 For j = i + 1 To UBound(sortedData, 1) If sortedData(i, 1) > sortedData(j, 1) Then temp = sortedData(i, 1) sortedData(i, 1) = sortedData(j, 1) sortedData(j, 1) = temp End If Next j Next i Set uniqueData = New Collection On Error Resume Next For i = 1 To UBound(sortedData, 1) uniqueData.Add sortedData(i, 1), CStr(sortedData(i, 1)) Next i On Error GoTo 0 With Me.ComboBox1 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With With Me.ComboBox2 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With End Sub الملف ترتيب البيانات ابجديا.xlsm

وعليكم السلام ورحمة الله وبركاته جرب الملف الكود Sub CalculateNetValues() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim dict As Object Dim key As Variant Dim totalValue As Double Dim expenseValue As Double Dim netValue As Double Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") For i = 4 To lastRow If Not dict.exists(ws.Cells(i, "C").Value) Then dict.Add ws.Cells(i, "C").Value, ws.Cells(i, "D").Value Else dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) + ws.Cells(i, "D").Value End If Next i For i = 4 To lastRow If dict.exists(ws.Cells(i, "C").Value) Then If IsNumeric(ws.Cells(i, "J").Value) Then dict(ws.Cells(i, "C").Value) = dict(ws.Cells(i, "C").Value) - ws.Cells(i, "J").Value End If End If Next i netValue = 0 For Each key In dict.keys netValue = netValue + dict(key) Next key ws.Range("O5").Value = netValue End Sub الملف تجارب اجمالى العهدة.xlsb

تفضل جرب الملف ذكور ثم انات 1.xlsb

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

وفيك بارك الله ,اعلم ذلك والا ما قمت انت والاستاذ محمد صالح يكفى وزيادة لك وافر التقدير الاحترام

يفترض فتح موضوع جديد ولكن بما انه نفس الملف مع تعديل في نفس الكود ذكور ثم انات.xlsb

السلام عليكم ورحمة الله وبركاتة تحياتى للاستاتذة الافاضل محمد صالح ومحمد هشام و حسين التجدى اعتقد ان صاحب الموضوع لم يكن طلبه الذكور في عمود والاناث في العمود المقابل بل بربد المزج بينهما في نفس العمود اول اسم ذكر الصف الذي يليه انثى وهكذا وهذا ما فهمته من ملفه المرفق حيث يوجد في طلبه الذكور في صف والاناث في صف على كل حال اذا كان فهمى للموضوع صحيحا فالكود التالى يلبى الطلب ان شاء الله وان كان فهمى للامر غير ذلك فعذرا من الجميع الكود Sub TransferStudentsByGenderAlternate22() Dim wsData As Worksheet Dim wsList As Worksheet Dim lastRow As Long Dim selectedClass As String Dim i As Long Dim rowMale As Long, rowFemale As Long Dim maleList As Collection, femaleList As Collection Dim studentName As String Dim studentGender As String Dim studentData As String Dim maxRows As Long Dim lastNumber As Long Dim currentNumber As Long Set wsData = ThisWorkbook.Sheets("قاعدة البانات") Set wsList = ThisWorkbook.Sheets("قوائم الفصول") selectedClass = wsList.Range("D5").Value lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).row Set maleList = New Collection Set femaleList = New Collection For i = 8 To lastRow If wsData.Cells(i, 3).Value = selectedClass Then ' التحقق من الفصل studentName = wsData.Cells(i, 2).Value studentGender = wsData.Cells(i, 4).Value studentData = wsData.Cells(i, 13).Value ' العمود M If studentGender = "ذكر" Then maleList.Add Array(studentName, studentData) ElseIf studentGender = "انثى" Then femaleList.Add Array(studentName, studentData) End If End If Next i rowMale = 7 rowFemale = 8 maxRows = 34 wsList.Range("B7:F40").ClearContents For i = 1 To Application.WorksheetFunction.Max(maleList.Count, femaleList.Count) If rowMale <= 40 Then If i <= maleList.Count Then wsList.Cells(rowMale, 2).Value = maleList(i)(0) wsList.Cells(rowMale, 3).Value = maleList(i)(1) rowMale = rowMale + 2 End If If i <= femaleList.Count And rowFemale <= 40 Then wsList.Cells(rowFemale, 2).Value = femaleList(i)(0) wsList.Cells(rowFemale, 3).Value = femaleList(i)(1) rowFemale = rowFemale + 2 End If ElseIf rowMale > 40 Then If i <= maleList.Count Then wsList.Cells(rowMale - 34, 5).Value = maleList(i)(0) wsList.Cells(rowMale - 34, 6).Value = maleList(i)(1) rowMale = rowMale + 2 End If If i <= femaleList.Count Then wsList.Cells(rowFemale - 34, 5).Value = femaleList(i)(0) wsList.Cells(rowFemale - 34, 6).Value = femaleList(i)(1) rowFemale = rowFemale + 2 End If End If Next i currentNumber = 1 For i = 7 To 40 If wsList.Cells(i, 2).Value <> "" Then wsList.Cells(i, 1).Value = currentNumber currentNumber = currentNumber + 1 End If Next i For i = 7 To 40 If wsList.Cells(i, 5).Value <> "" Then wsList.Cells(i, 4).Value = currentNumber currentNumber = currentNumber + 1 End If Next i End Sub الملف Microsoft Excel Worksheet جديد (3).xlsb

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

وعليكم السلام ورحمة الله وبركاته نعم، يمكنك ربط ملف Excel بملف Access عند عمل تحديث بيانات أو اضافة في ملف اكسل تنتقل هذه االتحديثات أو الاضافات أو التغييرات الى ملف اكسس اتبع الخطوات في الصور قاعدة بيانات.zip اكسل.xlsm

احد المواقع افادتي بالاني :- عندما تقوم بتنزيل ملف Excel من OneDrive وتحفظه على جهازك كملف محلي، فإن ارتباطه بالملف الأصلي على OneDrive سينقطع. يعني أن أي تغييرات تطرأ على الملف الموجود على OneDrive لن تنعكس في النسخة التي قمت بتنزيلها على جهازك. الحفاظ على الارتباط بالملف الأصلي على OneDrive للإبقاء على الارتباط بالملف الأصلي الموجود على OneDrive، يمكنك اتباع الطرق التالية: استخدام رابط المشاركة: بدلاً من تحميل الملف، يمكنك استخدام رابط المشاركة المباشر للملف في OneDrive. هذا سيمكنك من ربط الجدول في Access مباشرةً دون الحاجة لتنزيله. يمكنك استخدام الرابط كما يلي: في Access، عند إنشاء جدول مرتبط، أدخل رابط المشاركة مباشرة في مربع اسم الملف. تأكد من أن الرابط يؤدي مباشرةً إلى الملف (يجب أن يكون رابط التحميل وليس رابط العرض). مزامنة المجلد المشترك: كما ذكرت سابقًا، يمكنك إضافة المجلد المشترك إلى OneDrive الخاص بك، مما يسمح لك بمزامنة المحتويات مع جهاز الكمبيوتر. بمجرد إضافة المجلد، سيظهر في مجلد OneDrive المحلي، وسيظل مرتبطًا بالملف على OneDrive. إذا تم تحديث الملف على OneDrive، فإن النسخة المحلية ستتزامن تلقائيًا. خلاصة إذا قمت بتحميل الملف: الارتباط سيفقد، وأي تغييرات على OneDrive لن تؤثر على النسخة التي لديك محليًا. إذا استخدمت رابط المشاركة أو مزامنة المجلد: ستحافظ على الارتباط، وأي تغييرات في الملف على OneDrive ستظهر تلقائيًا في Access. إذا كنت بحاجة إلى الحفاظ على الارتباط، فالأفضل هو استخدام رابط المشاركة أو مزامنة المجلد موقع اخر افادني للأسف، بعد تنزيل الملف من OneDrive إلى جهاز الكمبيوتر، لن يبقى مرتبطًا تلقائيًا بملف Excel الأساسي الموجود على OneDrive. ستحتاج إلى إعادة إنشاء الرابط يدويًا بعد تنزيل الملف. إليك كيفية القيام بذلك: فتح الملف الذي تم تنزيله: افتح ملف Excel الذي قمت بتنزيله على جهاز الكمبيوتر. إعادة إنشاء الرابط: اذهب إلى علامة التبويب “بيانات” (Data) في Excel. اختر “تحرير الروابط” (Edit Links) من مجموعة “الاتصالات” (Connections). في نافذة “تحرير الروابط”، اختر الرابط الذي تريد تحديثه، ثم انقر على “تغيير المصدر” (Change Source). حدد ملف Excel الأساسي الموجود على OneDrive كمصدر جديد. حفظ التغييرات: بعد تحديث الروابط، احفظ الملف. بهذه الطريقة، ستتمكن من الحفاظ على الروابط بين الملفات حتى بعد تنزيلها. إذا كنت بحاجة إلى مزيد من المساعدة أو لديك أي استفسارات أخرى، لا تتردد في طرحها! 😊 1: Fix broken links to data - Microsoft Support 2: Problem with excel workbook links on onedrive - Microsoft Community

نعم لديك كل الحق نم التعديل في المشاركة السابقة

وعليكم السلام ورحمة الله وبركاته بعد اذن الاستاذ حجازى واثراءا للموضوع واظافة وهي عدم السماح للصف الذي به بيانات باظافة صف فارغ الا مرة واحدة الكود Private Sub CommandButton1_Click() Dim i As Long Dim ws As Worksheet Dim lastRow As Long Dim nextRowData As Long Set ws = ActiveSheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False lastRow = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ SearchFormat:=False).Row For i = lastRow To 2 Step -1 If Application.WorksheetFunction.CountA(ws.Rows(i)) > 0 Then nextRowData = Application.WorksheetFunction.CountA(ws.Rows(i + 1)) If nextRowData > 0 Then ws.Rows(i + 1).Insert Shift:=xlDown End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub الملف إضافة صف فارغ.xlsm

قدمت له استفسارك فاجابنى لإدخال جداول من ملف Excel الموجود في OneDrive كمصدر مرتبط في Microsoft Access، يمكنك اتباع الخطوات التالية: 1. الحصول على رابط المشاركة للملف: قم بفتح OneDrive عبر المتصفح. اذهب إلى الملف الذي شارك به صديقك. انقر على زر المشاركة (Share) واختر "نسخ الرابط" (Copy link) ليكون لديك رابط مباشر للملف. 2. تحميل الملف إلى جهاز الكمبيوتر: نظرًا لأن الملف لا يظهر في مجلد OneDrive على الكمبيوتر، يمكنك تحميله مباشرةً من الرابط الذي حصلت عليه. افتح الرابط في المتصفح. قم بتحميل الملف على جهاز الكمبيوتر. 3. استيراد الجداول إلى Access: افتح Microsoft Access. أنشئ قاعدة بيانات جديدة أو افتح قاعدة بيانات موجودة. اذهب إلى علامة التبويب "خارج البيانات" (External Data). اختر "Excel" من مجموعة استيراد & ربط. في مربع الحوار الذي يظهر، اختر "ربط إلى المصدر" (Link to the data source by creating a linked table). ابحث عن ملف Excel الذي قمت بتحميله، وحدده. اتبع التعليمات لإكمال عملية الربط. اختر الجداول التي ترغب في ربطها. 4. تأكيد الربط: بعد الانتهاء من عملية الربط، ستظهر الجداول في Access كجداول مرتبطة، ويمكنك استخدامها كما لو كانت جداول محلية.

المشكلة في الفراغات وبما ان الترقيم به ارقام ونصوص فيكون التنسيق نص كما تم وضع كود لازالة الفراغات الدالة =IFERROR(VLOOKUP(P5; 'صفحه البيانات'!$E$2:$F$10000; 2; FALSE); "غير موجود") الملف شرح الاسباب (1).xlsx

الملف السابق به تعديل المدى في الشيتات الثلاتة الاولى الكود السابق يبذأ من الصف 12 والصحيح انه 9 على كل حال الملف المرفق الحالى به زرين الاول الكود الاول مع التعديل والزر الاخر الكود بالمصفوفة وكلاهما سريعين جدا ترحيل الدرجات1.xlsm