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

وعليكم السلام ورحمة الله وبركاته اكتب التاريخ واسم المدرسة ثم اضغظ على زر بحث Sub SearchAndTransfer() Dim wsPlan As Worksheet Dim wsSearch As Worksheet Dim lastRowPlan As Long Dim lastRowSearch As Long Dim i As Long, j As Long Dim searchDate As String Dim searchSchool As String Dim dateFound As Boolean Set wsPlan = ThisWorkbook.Sheets("الخطة") Set wsSearch = ThisWorkbook.Sheets("بحث بالمدرسة") lastRowPlan = wsPlan.Cells(wsPlan.Rows.Count, "B").End(xlUp).Row searchDate = wsSearch.Range("D1").Value searchSchool = wsSearch.Range("C4").Value wsSearch.Rows("9:" & wsSearch.Rows.Count).ClearContents lastRowSearch = 9 For i = 6 To lastRowPlan dateFound = False For j = 5 To 31 ' المدى E5:AE5 يعني الأعمدة من 5 إلى 45 If wsPlan.Cells(5, j).Value = searchDate And wsPlan.Cells(i, j).Value = searchSchool Then dateFound = True Exit For End If Next j If dateFound Then wsSearch.Cells(lastRowSearch, 1).Value = lastRowSearch - 8 wsSearch.Cells(lastRowSearch, 2).Value = wsPlan.Cells(i, 3).Value wsSearch.Cells(lastRowSearch, 3).Value = wsPlan.Cells(i, 4).Value lastRowSearch = lastRowSearch + 1 End If Next i If lastRowSearch = 9 Then MsgBox "لم يتم العثور على أي بيانات ." Else MsgBox "تم نقل البيانات بنجاح!" End If End Sub بحث1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك اخي دمج الدلة للتعامل بشكل صحيح مع مدخلات متعددة تتضمن أكثر من نطاق على الشكل التالي Function dbsum(ParamArray Knowndb()) As Variant Dim firstsum As Double Dim rng As Range Dim i As Integer firstsum = 0 For i = LBound(Knowndb) To UBound(Knowndb) If TypeName(Knowndb(i)) = "Range" Then For Each rng In Knowndb(i) firstsum = firstsum + WorksheetFunction.Power(10, rng.Value / 10) Next rng Else firstsum = firstsum + WorksheetFunction.Power(10, Knowndb(i) / 10) End If Next i dbsum = 10 * WorksheetFunction.Log10(firstsum) End Function =dbsum(P11:P12,N9:N10) =dbsum(K11:K13,I9:I10) =dbsum(F9:F12) SumdB.xlsm كما يمكنك تعديل الدالة بحيث تكون أكثر كفاءة وقادرة على التعامل مع مجموعة متنوعة من المدخلات بما في ذلك النطاقات _ القيم الفردية _ والمصفوفات Function dbsum(ParamArray Knowndb()) As Variant Dim cnt As Double, rng As Range Dim i As Integer, j As Integer cnt = 0 On Error GoTo ErrorHandler For i = LBound(Knowndb) To UBound(Knowndb) Select Case TypeName(Knowndb(i)) Case "Range" For Each rng In Knowndb(i) If IsNumeric(rng.Value) Then cnt = cnt + WorksheetFunction.Power(10, rng.Value / 10) Else Err.Raise vbObjectError + 1, , "قيمة غير رقمية في النطاق" End If Next rng Case "Double", "Integer", "Single", "Currency", "Long" cnt = cnt + WorksheetFunction.Power(10, Knowndb(i) / 10) Case "Variant()" For j = LBound(Knowndb(i)) To UBound(Knowndb(i)) If IsNumeric(Knowndb(i)(j)) Then cnt = cnt + WorksheetFunction.Power(10, Knowndb(i)(j) / 10) Else Err.Raise vbObjectError + 2, , "قيمة غير رقمية في المصفوفة" End If Next j Case Else End Select Next i dbsum = 10 * WorksheetFunction.Log10(cnt) Exit Function ErrorHandler: dbsum = CVErr(xlErrValue) MsgBox "خطأ: " & Err.Description, vbCritical, "خطأ في الدالة dbsum" End Function SumdB.xlsm

وعليكم السلام ورحمة الله وبركاته ارجو ان اكون استوعبت فكرة عمل ملفك قمت بحذف التنسيقات للجداول لان الكود اظهر احطاء الاصناف التي ليس بها مبيعات اي خليتها فارغة لا يرحلها الكود Sub TransferData1() Dim ws As Worksheet Dim lastRow As Long, lastRowJ As Long Dim i As Long Dim found As Range Dim profitMatch As Boolean Dim userResponse As VbMsgBoxResult Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row userResponse = MsgBox("هل تريد الترحيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") If userResponse = vbYes Then For i = 5 To lastRow ' التحقق من وجود بيانات في العمود B If ws.Cells(i, "B").Value <> "" Then profitMatch = False lastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row Set found = ws.Range("J5:J" & lastRowJ).Find(ws.Cells(i, "A").Value, LookIn:=xlValues, LookAt:=xlWhole) If Not found Is Nothing Then If ws.Cells(i, "E").Value = ws.Cells(found.Row, "N").Value Then ws.Cells(found.Row, "K").Value = ws.Cells(found.Row, "K").Value + ws.Cells(i, "B").Value profitMatch = True End If End If If found Is Nothing Or Not profitMatch Then lastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row + 1 ws.Cells(lastRowJ, "J").Value = ws.Cells(i, "A").Value ws.Cells(lastRowJ, "K").Value = ws.Cells(i, "B").Value ws.Cells(lastRowJ, "L").Value = ws.Cells(i, "C").Value ws.Cells(lastRowJ, "M").Value = ws.Cells(i, "D").Value End If End If Next i End If End Sub الملف تقرير مبيعات1.xlsb

وعليكم السلام ورحمة الله وبركاته اللهم كن عونا وتصيرالاخواننا في فلسطين كان من المفترض ازالة الحماية من محرر الاكواد وحاولت بكلمة دارفشيان فلم تنجح , على كل حال تم فتح محرر الاكواد بطريقتى الخاصة ولكن جميع الاكواد غير موجودة ما يهمك الكود التالي انقله الى ملفك واربطه بزر الكود Sub ExportToWord1() Dim ws As Worksheet Dim wordApp As Object Dim wordDoc As Object Dim lastRow As Long Dim fileName As String Dim filePath As String Set ws = ThisWorkbook.Sheets("قائمة الأسماء") fileName = ws.Range("E4").Value If fileName = "" Then MsgBox "اسم الملف في الخلية E4 فارغ. يرجى إدخال اسم الملف." Exit Sub End If fileName = Application.WorksheetFunction.Clean(fileName) fileName = Replace(fileName, "/", "") fileName = Replace(fileName, "\", "") fileName = Replace(fileName, ":", "") fileName = Replace(fileName, "*", "") fileName = Replace(fileName, "?", "") fileName = Replace(fileName, """", "") fileName = Replace(fileName, "<", "") fileName = Replace(fileName, ">", "") fileName = Replace(fileName, "|", "") fileName = fileName & ".docx" filePath = ThisWorkbook.Path On Error Resume Next Set wordApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set wordApp = CreateObject("Word.Application") End If On Error GoTo 0 wordApp.Visible = True Set wordDoc = wordApp.Documents.Add lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row ws.Range("C1:E" & lastRow).Copy wordDoc.Content.Paste wordDoc.SaveAs2 filePath & "\" & fileName wordDoc.Close SaveChanges:=False wordApp.Quit Set wordDoc = Nothing Set wordApp = Nothing MsgBox "تم الترحيل بنجاح إلى الملف: " & fileName End Sub ____________ __________ ________ __________2.xlsm

هذا الكود سيحذف جميع الصفوف التي تحتوي على قيم غير فريدة في العمود المحدد بمعنى سيتم حذف جميع الصفوف التي تحتوي على قيم متكررة، بما في ذلك النسخة الأولى لكل قيمة Sub RemoveAllDuplicates() Dim f As Worksheet Dim Irow As Long, i As Long Dim dict As Object, tmp As Variant Dim uniqueDict As Object Dim n As Long Dim Col As String: Col = "A" Dim startRow As Long: startRow = 2 Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, Col).End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") Set uniqueDict = CreateObject("Scripting.Dictionary") n = 0 For i = startRow To Irow tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict.exists(tmp) Then dict(tmp) = dict(tmp) + 1 Else dict.Add tmp, 1 End If End If Next i For i = Irow To startRow Step -1 tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict(tmp) > 1 Then f.Rows(i).Delete n = n + 1 ElseIf dict(tmp) = 1 And uniqueDict.exists(tmp) Then f.Rows(i).Delete n = n + 1 Else uniqueDict.Add tmp, True End If End If Next i If n > 0 Then MsgBox "تم حذف جميع التكرارات" & vbCrLf & _ vbCrLf & "عدد الصفوف المحذوفة: " & n, vbInformation Else MsgBox "لم يتم العثور على أي تكرارات", vbInformation End If End Sub Supprimer_les_doublon.xlsb

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

شكراً على النصيحة لكن أأكد لك أن كل برامجى المصممة على أكسس 2000 وليست 2003 وحدها تعمل على كل الإصدارات التالية إنما كلامك _ أكيد _ أن كل البرامج المصممة على أكسس 2007 وما بعدها من المؤكد أنها لا تعمل على 2003

ضع هنا أحد ملفات mdb الخاصة بك لفحصه في النسخ الجديدة 🙂 من واقع تجربة أحيانا لا تعمل البرامج المصممة في نسخ 2003 - 2007 .. وفي الأغلب أن النسخ المصممة في النسخ الحديثة من 2010 وما بعدها لا تعمل في النسخ من 2007 وما قبلها . نصيحتي لك : أنتقل إلى نسخة 365 أو مابعد 2016 مثلا ، فأنت على بعد 20 سنة من التطور والتقنية والتحديثات التي تم تطويرها في البرنامج 🙂

بارك الله فيك اخونا الفاضل اتمنى لك كل التوفيق

كم افرحنى واسعدنى دعاؤك لي ولك بالمثل اخونا الفاضل

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

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

نعم بدون استخدام كود الاستاد الوزير لانة حسب اعتقادي اعتقد انك تريدها باستخدام الكود وليس استعلام

هذا التصميم للقوائم معتمد على اختيار واحد في N3 وما على يسارها في الصف الثالث ويصعب جدا تكرار كل هذه القوائم المساعدة لكل صف لذلك تحتاج إلى تغيير طريقة العمل إذا كنت بحاجة إلى نسخ الخلايا التي بها القوائم لأسفل أقترح عمل الآتي: وضع جميع عناصر القائمة في الصفوف التي أسفلها وتسمية هذا النطاق باسم رأس القائمة (طبعا اسم النطاق لا يوجد به مسافات لذلك يجب استبدال المسافات ب _ ) وإذا كان عنصر من هذه العناصر يندرج تحته عناصر أخرى يجب وضعه في عمود جديد وتسمية عناصره باسمه وهكذا وللحصول على القائمة الخاصة بالخلية A2 مثلا نضع في الخلية B3 قائمة التحقق ونضع مصدرها المعادلة التالية =INDIRECT(SUBSTITUTE(A3, " ", "_")) وهكذا مع باقي الأعمدة ويمكنك الرجوع لهذه الروابط بالتوفيق

كل الشكر والتقدير لكم أساتذتي الكرام

لم اجد من الكلمات ما اعبر به عما يدور بخاطرى ولكن جزاك الله خير الجزاء على هذا المجهود الرائع اخى عبدالله بشير عبدالله

وعليكم السلام ورحمة الله تعالى وبركاته صراحة لقد جربت الكود الخاص بك يشتغل بشكل جيد لاكن يمكنك تجربة هدا ربما يكون أسرع قم بحدف جميع الأكواد الموجودة داخل اليوزرفورم وضع الأكواد التالية Option Compare Text Dim f, TblPRODUCT, Col(), OneRng Private Sub UserForm_Initialize() Set f = Sheets("PRODUCT") TblPRODUCT = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value Col = Array(1, 2, 3, 4) OneRng = UBound(Col) + 1 filtre HideBar Me End Sub Sub filtre() temp1 = "*" & Me.TextBox6 & "*" temp2 = "*" & Me.TextBox5 & "*" Dim Tbl(): n = 0 For I = 1 To UBound(TblPRODUCT) If TblPRODUCT(I, 1) Like temp1 And TblPRODUCT(I, 2) Like temp2 Then n = n + 1: ReDim Preserve Tbl(1 To OneRng, 1 To n) c = 0 For Each k In Col c = c + 1: Tbl(c, n) = TblPRODUCT(I, k) Next k End If Next I If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End If Me.TextBox7.Value = n End Sub Private Sub TextBox6_Change() filtre End Sub Private Sub TextBox5_Change() filtre End Sub Private Sub ListBox1_Click() If Me.ListBox1.ListIndex <> -1 Then Me.TextBox1.Value = Me.ListBox1.Column(0, Me.ListBox1.ListIndex) Me.TextBox2.Value = Me.ListBox1.Column(1, Me.ListBox1.ListIndex) Me.TextBox3.Value = Me.ListBox1.Column(2, Me.ListBox1.ListIndex) Me.TextBox4.Value = Me.ListBox1.Column(3, Me.ListBox1.ListIndex) End If End Sub Private Sub UserForm_Activate() Me.Label23.Caption = Date UpdateTime End Sub Private Sub UpdateTime() Dim r As Long Dim startTime As Double startTime = Timer Do While Timer < startTime + 1 Me.Label22.Caption = Format(Now, "h:mm:ss") DoEvents For r = 1 To 100000: Next r Loop UpdateTime End Sub Private Sub CommandButton1_Click() ThisWorkbook.Save Application.Quit End Sub Private Sub CommandButton2_Click() Application.Visible = True Unload Me End Sub وفي Module1 Option Explicit #If VBA7 Then Public Declare PtrSafe Function FindWindow Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Public Declare PtrSafe Function GetWindowLong Lib "user32" _ Alias "GetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function DrawMenuBar Lib "user32" _ (ByVal hWnd As Long) As Long #Else Public Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Public Declare Function GetWindowLong Lib "user32" _ Alias "GetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Declare Function DrawMenuBar Lib "user32" _ (ByVal hWnd As Long) As Long #End If Sub HideBar(frm As Object) Dim Style As Long, Menu As Long, hWndForm As Long hWndForm = FindWindow("ThunderDFrame", frm.Caption) Style = GetWindowLong(hWndForm, &HFFF0) Style = Style And Not &HC00000 SetWindowLong hWndForm, &HFFF0, Style DrawMenuBar hWndForm End Sub أسعار القطع.xlsm

لحدفها يدويا اقتراح الاستاد @أ / محمد صالح سيوفي بالغرض أما ادا كانت لديك نية في استخدام الأكواد اليك بعض الحلول يمكنك تعديلها بما يناسبك لنفترض ان القيم المكررة موجودة في عمود (A) مثلا لحدف جميع التكرارات يمكنك استخدام هدا Sub Supprimer_doublons() ' حدف التكرارات بدون التأثير على الأعمدة المجاورة Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1") Set Col = f.Range("A2:A" & f.[A65000].End(xlUp).Row) For i = f.[A65000].End(xlUp).Row To 2 Step -1 If Application.CountIf(Col, f.Cells(i, 1)) > 1 Then f.Cells(i, 1).Delete Shift:=xlUp End If Next i Application.Calculation = xlAutomatic End Sub '***************************** Sub Supprimer_les_doublons() ' حدف الصف بالكامل Dim Irow As Long, dict As Object Dim i As Long, tmp As Variant 'قم بتحديد إسم العمود بما يناسبك Dim Col As String: Col = "A" ' قم بتحديد صف البداية Dim startRow As Long: startRow = 1 Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, "A").End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") For i = startRow To Irow tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict.exists(tmp) Then f.Rows(i).Delete i = i - 1 Irow = Irow - 1 n = n + 1 Else dict.Add tmp, True End If End If Next i If n = 0 Then MsgBox "لم يتم العثور على أي تكرارات ", vbInformation Exit Sub Else MsgBox "تم حذف " & n & " من التكرارات", vbInformation End If End Sub وهدا في حالة الرغبة لتحديد الحد الأقصى للتكرارات على العمود Sub Supprimer_les_doublons_sélectionnés() Dim f As Worksheet, n As Long Dim Irow As Long, i As Long Dim dict As Object, tmp As Variant Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, "A").End(xlUp).Row ' تحديد اسم العمود Dim Col As String: Col = "A" ' تحديد صف البداية Dim startRow As Long: startRow = 1 'عدد التكرارات Dim cnt As Long: cnt = 2 '<==== ' قم بتعديل عدد التكرارات المسموح بها بما يناسبك Set dict = CreateObject("Scripting.Dictionary") n = 0 For i = Irow To startRow Step -1 tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict.exists(tmp) Then dict(tmp) = dict(tmp) + 1 Else dict.Add tmp, 1 End If If dict(tmp) > cnt Then f.Rows(i).Delete n = n + 1 End If End If Next i If n = 0 Then MsgBox "لم يتم العثور على أي تكرارات تتجاوز العدد المسموح به", vbInformation Else MsgBox "تم حذف " & n & " من التكرارات الزائدة", vbInformation End If End Sub Supprimer_les_doublon.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته استكمالا للموضوع السابق لترحيل بيانات الاعمدة المدكورة بدون تكرار بنفس الفكرة السابقة مع امكانية تحديدها او تعديلها عند الحاجة داخل الكود يمكنك استخدام الكود التالي Sub Uniques_specific_range_array() '********** نسخ بدون تكرارات ************ Dim WSname As String, destName As String Dim ws As Worksheet, dest As Worksheet Dim dict As Object, j As Integer, i As Long Dim DataRngs As Variant, DestCols As Variant, arr As Variant Dim tmp As Boolean, allEmpty As Boolean, dictKey As Variant Dim destCol As Integer, cellValue As Variant ' قم بتحديد الأعمدة المرحلة بما يناسبك DataRngs = Array("B5:B200", "C5:C200", "D5:D200") ' قم بتحديد الأعمدة المرحل اليها DestCols = Array("B", "C", "D") WSname = InputBox(" : يرجى إدخال إسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox " تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If destName = InputBox(" : يرجى إدخال إسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox " تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If allEmpty = True For j = LBound(DataRngs) To UBound(DataRngs) arr = ws.Range(DataRngs(j)).value Set dict = CreateObject("Scripting.Dictionary") ' التحقق من وجود قيم على الأعمدة المرحلة tmp = Application.WorksheetFunction.CountA(ws.Range(DataRngs(j))) > 0 If tmp Then allEmpty = False For i = 1 To UBound(arr, 1) cellValue = arr(i, 1) If Len(cellValue) > 0 And Not dict.exists(cellValue) Then dict.Add cellValue, Nothing End If Next i ' إفراغ البيانات السابقة على الاعمدة المرحل إليها بداية من الصف 5 destCol = dest.Columns(DestCols(j)).Column With dest.Range(dest.Cells(5, destCol), dest.Cells(dest.Rows.Count, destCol)) .ClearContents: .ClearFormats End With '(نسخ القيم الفريدة) بداية من الصف 5 من ورقة الشهر المختارة i = 5 For Each dictKey In dict.Keys dest.Cells(i, destCol).value = dictKey i = i + 1 Next dictKey End If Next j If allEmpty Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في جميع الأعمدة المحددة" & " : " & "شهر", vbExclamation Exit Sub End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation End Sub ولنسخها مع وجود التكرارات اليك الكود التالي Sub Copier_Les_Valeurs_No_formatting() Dim WSname As String, destName As String Dim ws As Worksheet, dest As Worksheet Dim DataCols As Variant, DestCols As Variant Dim allEmpty As Boolean, srcData As Variant Dim j As Integer, lastRow As Long, DataRng As Range ' قم بتحديد الأعمدة المرحلة بما يناسبك DataCols = Array("B", "C", "D") ' قم بتحديد الأعمدة المرحل اليها DestCols = Array("B", "C", "D") WSname = InputBox(" : يرجى إدخال إسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox "تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If destName = InputBox(" : يرجى إدخال إسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox "تم إلغاء الترحــيل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If allEmpty = True For j = LBound(DataCols) To UBound(DataCols) lastRow = ws.Cells(ws.Rows.Count, DataCols(j)).End(xlUp).Row ' تحديد النطاق بداية من الصف 5 Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & lastRow) ' التحقق من وجود قيم على الأعمدة المرحلة If Application.WorksheetFunction.CountA(DataRng) > 0 Then allEmpty = False ' تحميل البيانات إلى مصفوفة srcData = DataRng.value ' إفراغ البيانات السابقة على الاعمدة المرحل إليه بداية من الصف 5 With dest.Range(dest.Cells(5, dest.Columns(DestCols(j)).Column), _ dest.Cells(dest.Rows.Count, dest.Columns(DestCols(j)).Column)) .ClearContents: .ClearFormats End With 'نسخ القيم بداية من الصف 5 من ورقة الشهر المختارة dest.Cells(5, dest.Columns(DestCols(j)).Column).Resize(UBound(srcData, 1), 1).value = srcData End If Next j If allEmpty Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في جميع الأعمدة المحددة" & " : " & "شهر", vbExclamation Exit Sub End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى شهر " & destName & " بنجاح", vbInformation End Sub ترحيل على حسب المطلوب فى العمل.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي لطباعة الكل او تحديد بيانات النجاح المرغوب طباعتها او حفظها بصيغة PDF بإسم الطالب في مجلد في نفس مسار الملف الرئيسي بادخال رقم البداية ورقم النهاية في مربع الاختيار Private Sub CommandButton1_Click() Dim PagFirst As Long, PagEnd As Long, i As Long Dim FolderName As String, MsgChoose As VbMsgBoxResult Dim filePath As String, wbPath As String, fileStart As String Dim fileEnd As String, fileName As String Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("بيان نجاح") Application.ScreenUpdating = False wbPath = ThisWorkbook.Path FolderName = "PDF_بيان النجــاح" filePath = wbPath & "\" & FolderName & "\" If Dir(filePath, vbDirectory) = "" Then On Error Resume Next MkDir filePath On Error GoTo 0 End If fileStart = InputBox("من أي بيان تريد البدء؟", "إدخال رقم البداية") fileEnd = InputBox("إلى أي بيان تريد الانتهاء؟", "إدخال رقم النهاية") If Not IsNumeric(fileStart) Or Not IsNumeric(fileEnd) Or Len(fileStart) = 0 Or Len(fileEnd) = 0 Then MsgBox "الرجاء إدخال أرقام بيانات النجاح صالحة", vbExclamation, "خطأ" Application.ScreenUpdating = True Exit Sub End If PagFirst = CLng(fileStart) PagEnd = CLng(fileEnd) If PagEnd > WS.Range("d1").Value Then MsgBox "رقم النهاية يتجاوز عدد الطلاب", vbExclamation, "تحذير" Application.ScreenUpdating = True Exit Sub End If If PagFirst > PagEnd Then MsgBox "رقم البداية يجب أن يكون أصغر من أو يساوي رقم النهاية", vbExclamation, "خطأ" Application.ScreenUpdating = True Exit Sub End If MsgChoose = MsgBox("لطباعة بيانات النجاح إظغط على نعم" & vbCrLf & vbCrLf & _ "لحفظ الملفات بصيغة بي دي إف إظغط لا" & vbCrLf & vbCrLf & _ "للخروج إظغط على إلغاء", _ vbYesNoCancel + vbQuestion, "إختر العملية") Select Case MsgChoose Case vbYes For i = PagFirst To PagEnd WS.Range("G1").Value = i WS.PrintOut Next i MsgBox "تم طباعة بيانات النجاح من " & PagFirst & " إلى " & PagEnd, vbInformation Case vbNo For i = PagFirst To PagEnd WS.Range("G1").Value = i fileName = Trim(WS.Range("D13").Value) If fileName = "" Then fileName = "بيان_" & Format(i, "000") End If filePath = wbPath & "\" & FolderName & "\" & fileName & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath Next i MsgBox "تم حفظ بيانات النجاح من " & PagFirst & " إلى " & PagEnd, vbInformation Case vbCancel MsgBox "تم إلغاء تنفيذ الكود", vbInformation End Select Application.ScreenUpdating = True End Sub بيان نجاح و للكشف درجات.xlsb

تفضل أخي الكريم تم استعمال نفس فكرة اليومي والخصم في نفس يوم تاريخ البداية مع اختلاف الشهور بالتوفيق خصم يومي أو شهري تلقائي .xlsx

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