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

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

وعليكم السلام في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. ومنها تقدر تحصل على السنة 🙂 هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

تفضل بالتوفيق test8102024.rar

عشان تقدر تطبق المطلوب كان لابد من عمد كود برمجة فيه داله اسمها MaxNumber تعمل المطلوب وبشكل مختصر هذا كود البرمجة: Function MaxNumber(rng As Range) As Double Dim cell As Range Dim matches As Object Dim largest As Double Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Global = True regex.IgnoreCase = True regex.Pattern = "\d+(\.\d+)?" largest = -1 For Each cell In rng If Not IsEmpty(cell.Value) Then Set matches = regex.Execute(cell.Value) If matches.Count > 0 Then Dim match As Variant For Each match In matches If CDbl(match.Value) > largest Then largest = CDbl(match.Value) End If Next match End If End If Next cell MaxNumber = largest End Function بعد كده اختار أي عمود تحتاجه عادي جدا زي ما بتعمل أي معادلة وهذه المعادلة كده بتكون : =MaxNumber(A1:A100) تحياتي 🙂 اكبر قيمه.xlsm

وعليكم السلام ورحمة الله وبركاته بعد اذن الاستاذ حجازى واثراءا للموضوع واظافة وهي عدم السماح للصف الذي به بيانات باظافة صف فارغ الا مرة واحدة الكود 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

و عليكم السلام و رحمة الله و بركاته تفضل أخي الكريم Sub InsertBlankRowForAllColumns() Dim lastRow As Long Dim lastColumn As Long Dim i As Long, j As Long ' تحديد آخر صف وآخر عمود يحتويان على بيانات lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastColumn = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' البدء من آخر صف والعمل إلى الأعلى For i = lastRow To 2 Step -1 ' التحقق من وجود بيانات في أي من الأعمدة For j = 1 To lastColumn If Cells(i, j).Value <> "" Then Rows(i + 1).Insert Shift:=xlDown Exit For ' الخروج من الحلقة الداخلية إذا وجدنا بيانات End If Next j Next i End Sub إضافة صف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا هل يشتغل معك عند محاولة الدخول لورقة 1 TEST.xlsb

ناسف ع التاخير غير المقصود ضغط العمل نسال الله دوام التوفيق و السداد للجميع العمل سيكون مقسم الي جزئين الجزاء الاول :- تصدير فاتوره المبيعات , مردوداتها الي ملف xml الحاله :- قريبا جدا بيكون جاهز الجزاء الثاني :- و هو الاهم و الاصعب ربط الحل التقني مع هيئه الزكاه و الدخل الحاله :- جاهز تنويه :- ممكن اي احد شغال ع vb.net او c# او اي لغه برجمه ياخد طريقه العمل ويطبقها بلغه البرمجه الخاصه بيه و هيشتغل معاه ان شاء الله رابط الملفات المستخدمه للعمل ملف الاكسس + البرامج المساعده https://drive.google.com/file/d/1vrIMbKFfU6_HgWipo3L8CLAOGwjvdTvj/view?usp=drive_link رابط ملف الاكسس فقط https://drive.google.com/file/d/1YY5an9X-NYjAx2ZSL6ipr_dQcihcLrCD/view?usp=drive_link رابط الشروحات (الموضوع طويل وفيه تفاصيل كثيره وحاولت ان اختصر قدر المستطاع ) للتواصل :- ايميل :- act32add.nm@gmail.com واتساب :- 00966597465617

حدد الخلية التي تحتوي على المعادلة (E3) توجه إلى علامة التبويب (Home) في شريط الأدوات في جزء التنسيق (Number Format) تحقق من نوع التنسيق المستخدم ستجده مضبوطا على (Text) قم بتغييره الى (General) عدم ظهور نتيجة المعادلة_٠٨٢٤١٠.xlsx تبسيط المعادلة =IF(AND(J3<>"", I3<>""), WORKDAY.INTL(I3, J3, 15), "")

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت تقصد انك ترغب بجمع القيمة الإجمالية في العمود "K" التي تتوافق مع القيم الفريدة في العمود "C" إليك اقتراح اخر بطريقة مختصرة Sub test1() Dim SumCel As Range Dim f As Worksheet, Irow As Long, r As Long Dim dict As Object, n As Double, tmp As String Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, "C").End(xlUp).Row Set SumCel = f.[O5] Set dict = CreateObject("Scripting.Dictionary") For r = Irow To 4 Step -1 tmp = f.Cells(r, "C").Value If Not dict.exists(tmp) Then dict.Add tmp, f.Cells(r, "K").Value End If Next r n = Application.Sum(dict.Items): SumCel.Value = n End Sub تجارب اجمالى العهدة V1.xlsb

بالإضافة لطريقة المهندس @محمد احمد لطفى جرب هذه الطريقة أيضا 🙂 : If IsDate(Me.datex) Then Me.datex2 = Year(CDate(Me.datex)) End If test8102024.rar

تحياتي للأستاذ / أمير حل رائع . إضافة بسيطة و هو كود لاستحراج أكبر قيمة مع النص الموجود بجانب الرقم Function LargestValueWithOriginalText(rng As Range) As String Dim cell As Range Dim matches As Object Dim maxNum As Double Dim num As Double Dim regex As Object Dim resultText As String ' Create a regular expression object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "\d+\.?\d*" ' Pattern to match numbers (including decimals) regex.Global = True maxNum = -1 ' Initialize maxNum to a low value resultText = "No numeric values found." ' Default message ' Loop through each cell in the specified range For Each cell In rng If Not IsEmpty(cell.Value) Then ' Find all matches in the cell Set matches = regex.Execute(cell.Value) ' Loop through all found matches For Each Match In matches num = CDbl(Match.Value) ' Convert match to a number If num > maxNum Then maxNum = num ' Update maxNum if the current number is larger resultText = cell.Value ' Store the text of the cell with the largest number End If Next Match End If Next cell ' If a number was found, return the original text If maxNum > -1 Then LargestValueWithOriginalText = resultText Else LargestValueWithOriginalText = resultText End If End Function اكبر قيمه (2).xlsm

يمكنك عمل ذلك من خلال التنسيق الشرطي عن طريق معادلة =OR(C$6="الجمعة",C$6="السبت") وتطبق على الخلايا C7:AH56 بالتوفيق

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

اتمني اكون سددت المطلوب Sub DeleteRows() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") Dim response As VbMsgBoxResult response = MsgBox("هل أنت متأكد أنك تريد نقل البيانات وحذفها من الجدول الأساسي؟", vbYesNo + vbQuestion, "تنبيه") If response = vbNo Then Exit Sub End If Dim lastRow As Long Dim lastRow1 As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row lastRow1 = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ws.Range("F3:J" & lastRow1).Clear ws.Range("A2:D" & lastRow).Copy ws.Range("G2").PasteSpecial Paste:=xlPasteAll ws.Range("A3:D" & lastRow).Clear ws.Range("F1:J1").Merge ws.Range("F1").Value = ws.Cells(1, 1).Value ws.Range("F1").NumberFormat = "dddd dd - mm - yyyy" With ws.Range("F1") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .Interior.Color = RGB(217, 217, 217) End With With ws.Range("F2:J2") .Interior.Color = RGB(217, 217, 217) .Font.Size = 16 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With With ws.Range("G3:J" & lastRow) .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ws.Cells(2, "F").Value = "ت" Dim i As Long For i = 3 To lastRow ws.Cells(i, "F").Value = i - 2 Next i ws.Range("F2:F" & lastRow).Borders.LineStyle = xlContinuous ws.Range("F2:F" & lastRow).HorizontalAlignment = xlCenter ws.Range("F2:F" & lastRow).VerticalAlignment = xlCenter ws.Columns("F").ColumnWidth = 6 ws.Columns("G").ColumnWidth = 16.88 ws.Columns("H").ColumnWidth = 19.68 ws.Columns("I").ColumnWidth = 19.38 ws.Columns("J").ColumnWidth = 8.5 Application.CutCopyMode = False ws.Cells(1, 1).Value = ws.Cells(1, 1).Value + 1 End Sub عمل تنسيقات بعد الضغط على الزر.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا مع تغيير أسماء الأعمدة بما يناسبك =SUMPRODUCT(--(B2:B12<>"")*(B2:B12<>"غ")*(B2:B12<>"غياب")*(B2:B12<>"تخلف")) المصنف1.xlsx

وعليكم السلام ورحمة الله وبركاته ,, اخي الكريم انت استخدمت الدالة DLookup لجلب رقم المقترض ( على ما أعتقد ) بناءً على اسم الموظف في الكومبوبوكس ، هل هذا صحيح ؟؟ وبإمكانك بدلاً من ذلك استخدام نفس مصدر الكومبوبوكس com1 ولكن هنا سنختار العمود رقم 2 حيث :- ( العمود 0 = اسم الموظف ، والعمود 1 = الجهة ، والعمود 2 = رقم المقترض ) ، لذا تم استبدال الجملة التالية :- Me.n2 = DLookup("[num]", "karz", "nam LIKE '*" & Me.com1 & "*'") بالجملة :- Me.n2 = com1.Column(2) أيضاً تم إجراء تعديل بسيط على عدد الأعمدة في الكومبوبوكس com1 وعرض كل عمود ؛ كما في الصورة :- الملف بعد التعديل القرضة الحسنة اصدار 31.zip

السلام عليكم ورحمة الله تعالى وبركاته الكود المقترح من الأستاد @حسونة حسين يشتغل بشكل جيد وينفد المطلوب مجرد اقتراح حاول وضع السطر التالي في حدث ورقة مبيعات الشهر مع ادخال بعض البيانات على اوراق العمل Private Sub Worksheet_Activate() Test End Sub في حالة الرغبة باستخدام الاكواد بدل الصيغ الموجودة على جميع اوراق العملاء ضع الكود التالي في حدث ThisWorkbook Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim lr As Long, n As Double, i As Long Dim totalD As Double, totalE As Double Dim WS As Worksheet: Set WS = Sh If InStr(1, WS.name, "عميل") = 0 Then Exit Sub If Not Intersect(Target, WS.Columns("D:E")) Is Nothing Or Not Intersect(Target, WS.Range("G6")) Is Nothing Then lr = Application.WorksheetFunction.Min(42, _ Application.WorksheetFunction.Max(WS.Cells(WS.Rows.Count, "D").End(xlUp).Row, _ WS.Cells(WS.Rows.Count, "E").End(xlUp).Row)) WS.Range("F9:F42").ClearContents n = WS.Range("G6").Value For i = 9 To lr If WS.Cells(i, "D").Value > 0 Or WS.Cells(i, "E").Value > 0 Then n = n + WS.Cells(i, "D").Value - WS.Cells(i, "E").Value WS.Cells(i, "F").Value = n End If Next i totalD = Application.WorksheetFunction.Sum(WS.Range("D9:D42")) totalE = Application.WorksheetFunction.Sum(WS.Range("E9:E42")) WS.Range("C44").Value = totalD WS.Range("C45").Value = totalE WS.Range("C46").Value = WS.Range("G6").Value + (totalD - totalE) End If End Sub واظافة الاسطر التالية اسفل كود الاستاد حسونة لحساب مجموع الاعمدة على ورقة مبيعات الشهر Dim totals(1 To 3) As Double Sh.[A1].Value = "قائمة تعاملات عملاء 6 أكتوبر حتى يوم: " & Format(Date, "dd/mm/yyyy") For i = 1 To 3 totals(i) = Application.WorksheetFunction.Sum(Sh.Range(Cells(3, i + 2), Cells(152, i + 2))) Sh.Cells(153, i + 2).Value = totals(i) Next i Customers-Project-02.xlsb

وعليكم السلام ورحمة الله وبركاته جرب الملف الكود 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

ومشاركة مع أستاذي الجليل @jjafferr Me.YourTextBox = UCase(Me.YourTextBox)

وعليكم السلام اذا الحقل: me.abc="i am small letters" لتكبير الحروف me.abc= Format(me.abc, ">")

عدلت العنوان من اجل يكون قريب للباحث وهذه طريقة اخرى ايضا Me.datex2 = Format(CDate(datex), "yyyy")

الحمد لله والف شكر على هذه الكلمات الطيبات

السلام عليكم ورحمة الله وبركاتة تحياتى للاستاتذة الافاضل محمد صالح ومحمد هشام و حسين التجدى اعتقد ان صاحب الموضوع لم يكن طلبه الذكور في عمود والاناث في العمود المقابل بل بربد المزج بينهما في نفس العمود اول اسم ذكر الصف الذي يليه انثى وهكذا وهذا ما فهمته من ملفه المرفق حيث يوجد في طلبه الذكور في صف والاناث في صف على كل حال اذا كان فهمى للموضوع صحيحا فالكود التالى يلبى الطلب ان شاء الله وان كان فهمى للامر غير ذلك فعذرا من الجميع الكود 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

أخي أزهر .. حسب تصوري للموضوع أنك تريد نظام لمعرفة السجلات المضافة من قبل المستخدمين الآخرين وهل تم قرائتها من قبلك أم لا .. إن كان هذا هو مطلبك .. فستحتاج أن تضيف حقلين نصيين في الجدول .. الأول ( أضيف بواسطة ) : .. وفيه يتم تسجيل أسم المستخدم الذي أضاف السجل ... ويوضع في حدث قبل الإدراج. الثاني (قُرِئِت) : ... وفيه يتم إضافة اسماء المستخدمين الذين فتحو هذا السجل .. ويوضع في حدث عند الحالي وتعمل استعلام يقوم بحصر السجلات الغير مقروءة من قبلك .. فإن كان عددها أكبر من 1 تظهر لك الرسالة التنبيهية التي تريدها .. وسلامتك 🙂🖐 تم إضافة جميع ما سبق إلى ملفك : mr.accdb

السلام عليكم ورحمة الله تعالى وبركاته كما وضح الأستاد @أ / محمد صالح يجب عليك وضع الكود في حدث ورقة قوائم الفصول لاكن اخي @حسين النجدى الصورة تظهر مشكلة في أسماء أوراق العمل داخل مشروع VBA حيث يتم عرض الأسماء على شكل "?????" هذه المشكلة غالبا تتعلق بعدم دعم الترميز العربي بشكل صحيح داخل Excel أو محرر VBA مما يسبب ظهور رسالة الخطأ معك . تأكد من أن إعدادات اللغة في نظام التشغيل عندك على الجهاز مضبوطة للغة العربية اذهب إلى Control Panel > Clock and Region > Region ثم في تبويب Administrative اضغط على Change system locale وتأكد من ظبط اللغة العربية 1) اذا كان هذا لا يناسبك جرب الإشارة مباشرة داخل الكود إلى الأسماء الفعلية المستخدمة في المصنف الخاص بك على الشكل التالي Set wsDatabase = Worksheet____1 Set wsLists = Worksheet____3 2) بعد إذن الأستاذ محمد صالح و إثراءا للموضوع اليك حل اخر مع بعض الاظافات البسيطة لتنفيد الكود بنفس الطريقة (عند التغيير في الخلية D5) Const Classe As String = "D5" Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target.Address(0, 0) Case Classe Dim clé As String Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long, n As Long, r As Long Dim Rng As Variant, a As Variant, OnRng As Variant Set WS = Worksheet____1 Set dest = Worksheet____3 clé = dest.[D5].Value If clé = "" Then Exit Sub Application.ScreenUpdating = False If WS.AutoFilterMode Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row OnRng = WS.Range("B2:D" & lastRow).Value ReDim Rng(1 To lastRow, 1 To 3) ReDim a(1 To lastRow, 1 To 3) For i = 1 To UBound(OnRng, 1) If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then Select Case OnRng(i, 3) Case "ذكر" n = n + 1 Rng(n, 1) = n: Rng(n, 2) = OnRng(i, 1) Rng(n, 3) = WS.Cells(i + 1, "M").Value Case "انثى" r = r + 1 a(r, 1) = r: a(r, 2) = OnRng(i, 1) a(r, 3) = WS.Cells(i + 1, "M").Value End Select End If Next i If n = 0 And r = 0 Then MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation Else Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents If n > 0 Then dest.Range("A7").Resize(n, 3).Value = Application.Index(Rng, _ Evaluate("ROW(1:" & n & ")"), Array(1, 2, 3)) End If If r > 0 Then dest.Range("D7").Resize(r, 3).Value = Application.Index(a, _ Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3)) End If End If Application.ScreenUpdating = True End Select End Sub او Sub ClassData() Dim WS As Worksheet, dest As Worksheet Dim clé As String Dim lastRow As Long, i As Long, n As Long, r As Long Dim Rng As Variant, a As Variant, OnRng As Variant ' Code.............. .................... If r > 0 Then dest.Range("D7").Resize(r, 3).Value = Application.Index(a, _ Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3)) End If End If Application.ScreenUpdating = True End Sub بالتوفيق ......... قوائم.xlsm

يمكنك تجربة هذه الكود في حدث التغيير في شيت قوائم الفصول مع تصويب اسم الشيت قاعدة البيانات كلك يمين على اسم الشيت قوائم الفصول ثم view code ثم لصق هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$5" Then Dim wsDatabase As Worksheet Dim wsLists As Worksheet Dim lastRow As Long Dim i As Long Dim maleRow As Long, femaleRow As Long Dim lastMaleNumber As Long Set wsDatabase = ThisWorkbook.Sheets("قاعدة البيانات") Set wsLists = ThisWorkbook.Sheets("قوائم الفصول") wsLists.Range("A7:C40").ClearContents wsLists.Range("D7:F40").ClearContents maleRow = 7 femaleRow = 7 lastRow = wsDatabase.Cells(wsDatabase.Rows.Count, "B").End(xlUp).Row For i = 2 To lastRow If wsDatabase.Cells(i, "C").Value = wsLists.Range("D5").Value Then If wsDatabase.Cells(i, "D").Value = "ذكر" Then wsLists.Cells(maleRow, 1).Value = maleRow - 6 wsLists.Cells(maleRow, 2).Value = wsDatabase.Cells(i, "B").Value wsLists.Cells(maleRow, 3).Value = wsDatabase.Cells(i, "M").Value maleRow = maleRow + 1 End If End If Next i lastMaleNumber = maleRow - 7 femaleRow = 7 For i = 2 To lastRow If wsDatabase.Cells(i, "C").Value = wsLists.Range("D5").Value Then If wsDatabase.Cells(i, "D").Value = "انثى" Then wsLists.Cells(femaleRow, 4).Value = lastMaleNumber + (femaleRow - 6) wsLists.Cells(femaleRow, 5).Value = wsDatabase.Cells(i, "B").Value wsLists.Cells(femaleRow, 6).Value = wsDatabase.Cells(i, "M").Value femaleRow = femaleRow + 1 End If End If Next i End If End Sub بالتوفيق

السلام عليكم ورحمة الله وبركاته.. كنت اعمل على مشروع للقرآن الكريم، يكون ضمن تطبيق قوت القلوب، صورته في التوقيع 🥰 البرنامج من تصميمي وبرمجتي 100% فاحتجت للقرآن الكريم مرتل ومقسم لايات قمت بالعثور على ختمات كاملة وللعديد من القرآء في موقع Archive.org فقمت بتحويل الروابط الى قاعدة بيانات SQLite تتضمن ترتيل القرآن الكريم على شكل ايات كل آية على حدا وبرابط مباشر، أي ستقوم بتشغيل الصوت من الرابط مباشرة بدون تنزيلة طبعا يمكنكم تشغيل الصوت مباشرة من الويب باستخدام الكثير من المكتبات المجانية مثل NAudio.dll وغيرها... قبل كل شيء، هذا الكود لإنشاء الجدول sounds الذي ستكون فيه روابط الصوت لايات القرآن الكريم في قاعدة البيانات.. 1. تسلسل السورة 2. رقم الآية 3. رابط الملف الصوتي للآية 4. معرف القارئ CREATE TABLE "sounds" ( "surah_number" INTEGER, "ayah_number" INTEGER, "audio_url" TEXT, "reader_id" INTEGER ); 0. احمد نعينع 1. الطبلاوي 2. عبد الباسط 3. المنشاوي 4. الحصري السورس كود للفائدة، الذي يقوم بتوليد الايات حسب السور بلغة NET. Sub GenerateQuranAudioLinks(ByVal baseUrl As String, ByVal reader_id As String) ' عدد الآيات لكل سورة من القرآن الكريم Dim surahAyatCounts As Integer() = { 7, 286, 200, 176, 120, 165, 206, 75, 129, 109, 123, 111, 43, 52, 99, 128, 111, 110, 98, 135, 112, 78, 118, 64, 77, 227, 93, 88, 69, 60, 34, 30, 73, 54, 45, 83, 182, 88, 75, 85, 54, 53, 89, 59, 37, 35, 38, 29, 18, 45, 60, 49, 62, 55, 78, 96, 29, 22, 24, 13, 14, 11, 11, 18, 12, 12, 30, 52, 52, 44, 28, 28, 20, 56, 40, 31, 50, 40, 46, 42, 29, 19, 36, 25, 22, 17, 19, 26, 30, 20, 15, 21, 11, 8, 8, 19, 5, 8, 8, 11, 11, 8, 3, 9, 5, 4, 7, 3, 6, 3, 5, 4, 5, 6 } ' حلقة لتوليد جمل SQL لكل سورة وآياتها For surah As Integer = 1 To 114 Dim surahNumber As String = surah.ToString("D3") ' تحويل رقم السورة إلى 3 أرقام Dim ayatCount As Integer = surahAyatCounts(surah - 1) ' توليد جمل SQL بناءً على عدد الآيات لكل سورة For ayah As Integer = 0 To ayatCount Dim ayahNumber As String = ayah.ToString("D3") ' تحويل رقم الآية إلى 3 أرقام Dim fileUrl As String = baseUrl & surahNumber & ".zip" & "/" & surahNumber & ayahNumber & ".mp3" Dim sqlInsert As String = "INSERT INTO sounds (surah_number, ayah_number, audio_url, reader_id) VALUES (" & surah & "," & ayah & "," & "'" & fileUrl & "'" & "," & reader_id & ");" My.Computer.FileSystem.WriteAllText(Application.StartupPath & "\sql_" & reader_id & ".txt", sqlInsert & vbNewLine, True) Next Next '' تشغيل كل عملية في ثريد منفصل باستخدام Task 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb---a7mad--n3ena3---morattal------quran----6236---ayaat-----__verse--by---_189/", "1")) 'احمد نعينع 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb__---mp3------------quran----6236---ayaat-----__verse--by---verse----_-by-/", "2")) 'الطبلاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/192kb----morattal----quran----6236---ayaat-----__verse--by---verse----_-by--ab_525/", "3")) 'عبد الباسط 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb____--mp3-------full-----quran----6236---ayaat-----__verse--by---verse---/", "4")) 'المنشاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb___--mp3-----quran----6236---ayaat-----__verse--by---verse----_-by---alhos/", "5")) 'الحصري End Sub ارفقت لكم البيانات على شكل ملفات TXT لكي تعدلو عليها كيفما شئتم. لا تنسوني ووالدي من صالح دعائكم SQLite.zip

@AmirMohamed ماشاء الله عمل رائع مع وافر الشكر والتقدير لشخصكم الكريم واداره المنتدى

تم التعديل وشرح االأسباب OK شرح الاسباب.xlsx

الكود في الملف مكتوب لنواة ويندوز مختلفة مثلا 32بت والنسخة الحالية 64بت وإذا كان لك صلاحية الدخول على الكود يمكنك وضع كلمة ptrsafe قبل اسم الدالة أو الإجراء مثل هذا الكود #If VBA7 Then Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr #Else Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If بالتوفيق

تمام اخي الكريم تفضل وهذه المعادلة المستخدمة : =IF($C$2<>"";TRANSPOSE(IFERROR(INDEX(UNIQUE(FILTER($B:$B; $A:$A = $C$2)); ROUNDUP(COLUMN(A1)/2; 0)); ""));"") HHA (1).xlsx

يمكنك استعمال هذه المعادلة في الخلية D6 =IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6,الاسماء!$F$6:$F$215,0)),"") ثم سحب المعادلة للأسفل ويسارا وإذا كنت تستعمل النسخ الحديثة للأوفيس يمكنك استعمال هذه المعادلة بدون سحب في الخلية D6 فقط' =IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6:AD230,الاسماء!$F$6:$F$215,0)),"") بالتوفيق

تفضل تعديلات جوهرية 1- اختصار 3 نماذج الى نموذج واحد ( الوارد / الصادر / التلفيات ) من اجل سهولة التعديل والتطوير .. حيث يكون العمل من مكان واحد 2- عملت ضوابط في النموذج حسب نوع العملية .. لزيادة التحكم 3- فك ارتباط النماذج بالجداول ، وادخال البيانات عبر مجموعة السجلات .. ونكسب من هذه الطريقة : A- منع الحفظ التلقائي B- عدم الحاجة لعمليات الحذف ( اما الحفظ واما الخروج وعدم الحفظ ) stock12 .rar

لا اعلم مادا تقصد هل كيفية ادراج الكود او كيفية تطبيقه على ملفات اخرى الاولى لايمكنني شرحها يمكنك البحث عنها ستجدها صوة وصورة اما الاحتمال الثاني وهو الارجح على ما اعتقد لكي تطبق الكود على ملفات اخرى لابد ان تفهمه اولا لتتمكن من تعديله بما يناسبك سأقوم بمحاولة اظافة بعض التعليقات المهمة للتوضيح Sub Collection_of_books_Sheet1() '****"RS_ST_196"' هذا الماكرو يقوم بتجميع أسماء الطلاب والكتب من ورقة ' ويقوم بنسخها إلى ورقة1 مع حساب عدد الكتب لكل طالب Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long Dim studentName As String, bookName As String, n As String Dim bookNumber As Variant, row As Range, lr As Long Dim startRow As Long, ling As Long, bCount As Integer Dim rngCell As Range Application.ScreenUpdating = False '***** تحديد أوراق العمل Set WS = ThisWorkbook.Sheets("RS_ST_196") Set dest = ThisWorkbook.Sheets("Sheet1") '******** "RS_ST_196" ,ورقة ' تحديد آخر صف في العمود AK lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row With dest.Range("A2:C" & dest.Cells(dest.Rows.Count, "A").End(xlUp).row) .ClearContents ' مسح جميع البيانات في النطاق .ClearFormats ' مسح جميع التنسيقات في النطاق End With ling = 2 ' بدء الكتابة من الصف 2 في ورقة "Sheet1" ' حلقة لتمرير جميع الصفوف في ورقة المصدر من الصف 18 إلى آخر صف مستخدم For i = 18 To lastRow ' التحقق مما إذا كان الصف مخفيًا (إذا لم يكن مخفيًا، يتم معالجة الصف) If Not WS.Rows(i).Hidden Then ' الحصول على اسم الطالب من العمود "AK" studentName = WS.Cells(i, "AK").Value ' التحقق مما إذا كان اسم الطالب يبدأ بـ "اسم الطالب: " If InStr(studentName, "اسم الطالب: ") = 1 Then ' إزالة "اسم الطالب: " من بداية النص للحصول على الاسم الفعلي للطالب studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" ' لتجميع أسماء الكتب bCount = 0 ' عداد للكتب startRow = i + 2 ' البدء من الصف الذي يليه للتحقق من الكتب ' حلقة لتمرير جميع الكتب المرتبطة بالطالب Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value '(عمود التسلسل م) التأكد من أن الكتاب ليس مجرد عنوان عمود وأن رقم الكتاب غير فارغ If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And Not IsEmpty(bookNumber) Then ' تجميع أسماء الكتب في متغير n If n = "" Then n = bookName Else n = n & " + " & bookName End If bCount = bCount + 1 ' زيادة عدد الكتب لكل طالب End If startRow = startRow + 1 ' الانتقال إلى الصف التالي Loop '** نسخ النتائج ' كتابة اسم الطالب، أسماء الكتب المجتمعة، وعدد الكتب في ورقة الوجهة dest.Cells(ling, "A").Value = studentName ' اسم الطالب dest.Cells(ling, "B").Value = n ' أسماء الكتب dest.Cells(ling, "C").Value = bCount ' عدد الكتب ling = ling + 1 ' الانتقال إلى الصف التالي لكتابة بيانات الطالب التالي End If End If Next i '** تحديد آخر صف مستخدم في الاعمدة A:C "Sheet1" lr = dest.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set rngCell = dest.Range("A2:C" & lr) '** تنسيق الخلايا في النطاق المحدد With rngCell .Font.Bold = True ' تنسيق الخط .MergeCells = False ' التأكد من عدم دمج الخلايا .HorizontalAlignment = xlCenter ' ضبط المحاذاة الأفقية إلى الوسط .VerticalAlignment = xlCenter ' ضبط المحاذاة الرأسية إلى الوسط .WrapText = True ' تفعيل التفاف النص ' ضبط ارتفاع الصفوف إلى 35 For Each row In .Rows row.RowHeight = 35 Next row End With '** إضافة حدود للخلايا في النطاق For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

اعرض الملف ✨نصوص متحركة ✨ .. 4 أربعة أشكال متنوعة مما لذ وطاب 😊👌 السلام عليكم ورحمة الله وبركاته 🙂 هذي من بعض التجارب على عمل أشكال جديدة على النصوص المتحركة .. وقد خلصت التجارب إلى التالي 🙂 للاستفادة من المثال : لدينا أربعة نماذج ، كل واحد منها يحتوي على أحد الأشكال الموضحة بالترتيب .. قم بفتح النموذج المراد تطبيقه ثم أنقل الأكواد مثل ما هي إلى برنامجك + الليبل الموجود في النموذج ( ويمكنك أستخدام الليبل الخاص بك ) قم فقط بتعديل النص المراد تحريكة + اسم الليبل الذي سيتحرك النص بداخله . صاحب الملف Moosak تمت الاضافه 03 أكت, 2024 الاقسام قسم الأكسيس  

وعليكم السلام ورحمة الله وبركاته معلمنا العود ، عدت والعود أحمد 😊🌹🌼 بل خسارتنا أحنا أكبر لما تغيب عنا ونفتقد توجيهاتك وخبراتك 😅🖐

السلام عليكم 🙂 في الواقع انا خسارتي كبيرة لغيابي عن المنتدى لفترات طويلة ، لأني ما اشوف و اواكب واتعلم واستفيد من مثل هذه الابداعات الجميلة 🙂 شكرا لك اخوي موسى 🙂 جعفر

السلام عليكم أخي @gavan 🙂 ما اسم الجدول المستهدف؟ وما اسم الحقل المراد جمعه ؟ وهل هناك شروط أخرى للجمع غير أن التاريخ يجب أن يكون قبل التاريخ المعطى ؟ ولو تكرمت أضف المزيد من السجلات للتأكد من سلامة التطبيق .. لا يمكن التحقق من سلامة النتيجة ب 3 مدخلات فقط !!

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

تفضل اخي الحبيب وهذه المعادلة المستخدمة : =IF(B3<>""; SUBTOTAL(3; $B$2:B3); "") اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له box (1).xlsm

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

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

وعليكم السلام ورحمة الله وبركاته حسب فهمي لطلبك الكود Sub FilterAndCopyData() Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, wsDest As Worksheet Dim searchValue As String Dim rng As Range, cell As Range Dim lastRow As Long, destRow As Long Dim serialNumber As Long Set ws1 = ThisWorkbook.Sheets("SHEET1") Set ws2 = ThisWorkbook.Sheets("SHEET2") Set ws3 = ThisWorkbook.Sheets("SHEET3") Set wsDest = ThisWorkbook.Sheets("SAAD") wsDest.Range("C13:R" & wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row).ClearContents searchValue = wsDest.Range("N7").Value destRow = 13 serialNumber = 1 For Each ws In Array(ws1, ws2, ws3) lastRow = ws.Cells(ws.Rows.Count, "P").End(xlUp).Row Set rng = ws.Range("P12:P" & lastRow) For Each cell In rng.Cells If cell.Value = searchValue Then wsDest.Cells(destRow, "C").Value = serialNumber wsDest.Cells(destRow, "F").Value = cell.Offset(0, -10).Value wsDest.Cells(destRow, "J").Value = cell.Offset(0, -6).Value wsDest.Cells(destRow, "L").Value = cell.Offset(0, -4).Value wsDest.Cells(destRow, "M").Value = cell.Offset(0, -3).Value wsDest.Cells(destRow, "P").Value = cell.Value wsDest.Cells(destRow, "Q").Value = cell.Offset(0, 1).Value wsDest.Cells(destRow, "R").Value = cell.Offset(0, 2).Value destRow = destRow + 1 serialNumber = serialNumber + 1 End If Next cell Next ws End Sub الملف ترحيل الدرجات1.xlsm

شكرا وجزاء الله كل خير وجعلها الله في ميزان حسناتكم

جميل جدا ذكرتني الشاطىء وامواجه لا تلمني اقرب بحر لنا يبعد اكثر من 500 كم

بعد اذن الكبير ابو خليل استاذنا الغالي💖 حبيبي جرب ان تفتح ملف اكسس فارغ و استدعي جميع الكائنات (جداول و استعلامات و الخ ) كل المحتويات من الملف الذي لايفتح External data من تبويب Import&link من فرع New Data Source من زر From Database ومن الاختيار ستفتح نافذة اختار الملف الذي لايفتح , واعمل عليه ووافينا بالنتيجة تحياتي

حبيبي الغالي ممكن ترفع الملف لنتمكن من الفهم اكثر , يالغالي

مرحبا بك استعمل دالة Dlast DLast ( ''Field"' , ''Table or Query'' [, criteria] )