محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim WS As Worksheet, f As Worksheet Dim r As Range, DataRng As Range If Not Intersect(Target, Me.Range("C17")) Is Nothing Then Set WS = Sheets("الرئيسية") Set f = Sheets("لوحة المعلومات") WS.Activate If WS.AutoFilterMode Then WS.AutoFilterMode = False End If Set DataRng = WS.Range("A1").CurrentRegion With DataRng .AutoFilter Field:=10, Criteria1:="تحت الاجراء" End With On Error Resume Next Set r = WS.Range("J:J").SpecialCells(xlCellTypeVisible) On Error GoTo 0 If r Is Nothing Then MsgBox "لم يتم العثور على أي صفوف تحتوي على تحت الاجراء", vbInformation WS.AutoFilterMode = False End If Application.Goto WS.Range("J3") End If End Sub

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة الملف لاحظت انك ترغب بحدف الخلايا الفارغة مع البقاء على البيانات بمكانها الاصلي مع مراعات عدم التاثير على الاعمدة المجاورة لانها ربما تحتوي على معادلات جرب هدا Sub Supp_lignes_VidesArray() Dim n&, i&, j&, k&, Irow& Dim a As Variant, arr As Variant Dim f As Worksheet: Set f = Sheets("Sheet1") Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow < 4 Then Exit Sub a = f.Range("B4:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then n = n + 1 End If Next i If n = 0 Then Exit Sub Application.ScreenUpdating = False ReDim arr(1 To n, 1 To UBound(a, 2)) j = 0 For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then j = j + 1 For k = 1 To UBound(a, 2) arr(j, k) = a(i, k) Next k End If Next i f.Range("B4:E" & Irow).ClearContents f.Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Application.ScreenUpdating = True End Sub وهدا في حالة كانت البيانات على الاعمدة B-C-D-E تحتوي على صيغ يجب الاحتفاظ بها عند التخلص من الخلايا الفارغة Sub Supp_lignes_Returns_formulas() Dim n&, i&, j&, k&, Irow& Dim a As Variant, arr As Variant Dim f As Worksheet: Set f = Sheets("Sheet1") Irow = f.Columns("B:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow < 4 Then Exit Sub a = f.Range("B4:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then n = n + 1 End If Next i If n = 0 Then Exit Sub ReDim arr(1 To n, 1 To UBound(a, 2)) Application.ScreenUpdating = False j = 0 For i = 1 To UBound(a, 1) If a(i, 1) <> "" And a(i, 2) <> "" And a(i, 3) <> "" And a(i, 4) <> "" Then j = j + 1 For k = 1 To UBound(a, 2) If f.Cells(i + 3, k + 1).HasFormula Then arr(j, k) = f.Cells(i + 3, k + 1).Formula Else arr(j, k) = f.Cells(i + 3, k + 1).Value End If Next k End If Next i f.Range("B4:E" & Irow).ClearContents f.Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Application.ScreenUpdating = True End Sub New Microsoft Excel Worksheet v2.xlsb

صراحة لا اعلم ما تبحث عنه كان من المفروض ارفاق عينة للنتائج المتوقعة بعد اظافتها يدويا لتسهيل فهم طلبك جرب احدى المعادلات التالية ربما تفيدك =IF(L2>0, IF(F2<H2, IF(D2<=L2, D2, L2), IF(G2<I2, IF(E2<=L2, E2, L2), "")), "") OR =IF(L2>0, IF(F2<H2, IF(F2<=L2, D2, ""), IF(G2<I2, IF(G2<=L2, E2, ""), "")), "") OR =IF(ISBLANK(L2), "", IF(F2<H2, IF(D2<=L2, D2, L2), IF(G2<I2, IF(E2<=L2, E2, L2), ""))) OR =IF(ISBLANK(L2), "", IF(F2<H2, MIN(D2, L2), IF(G2<I2, MIN(E2, L2), ""))) Book1 TEST.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا ربما يناسبك Module Sub ProtectWS() Dim sh As Variant, MyArray As Variant, Password As String Password = "1234" MyArray = Array(Sheet1, Sheet2) ' <<=== ' اسماء الاوراق المرغوب حمايتها For Each sh In MyArray sh.Protect Password, UserInterfaceOnly:=True, AllowFiltering:=True Next sh End Sub ThisWorkbook Private Sub Workbook_Open() ProtectWS End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) ProtectWS End Sub وفي حدث الاوراق المحددة Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Password As String Dim Clé As String Password = "1234" ' الباسوورد الخاص بك If Me.ProtectContents Then Clé = InputBox(" الورقة محمية يرجى إدخال كلمة المرور") If Clé = Password Then Me.Unprotect Password Else MsgBox "كلمة المرور غير صحيحة", vbCritical Exit Sub End If End If End Sub ' في جالة الرغبة بنسخ البيانات من ورقة لاخرى يمكنك تعطيل الكود التالي Private Sub Worksheet_Deactivate() Dim Password As String Password = "1234" Me.Protect Password End Sub test.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة النتيجة المتوقعة جرب وضع الصيغ التالية F2 =IF(OR(A2="احاله", A2="وفاه"), IF(DATEDIF(C2,D2,"y")>=5, 0, DATEDIF(C2,D2,"md")), DATEDIF(B2,E2,"md")) G2 =IF(OR(A2="احاله", A2="وفاه"), IF(DATEDIF(C2,D2,"y")>=5, 60, DATEDIF(C2,D2,"m")), DATEDIF(B2,E2,"m")) الفرق بين تاريخين لاكثر من شرط.xlsx

Sub Copier_Les_Valeurs_With_formats_Advanced() 'Variables On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual ' قم بتحديد الأعمدة المرحلة بما يناسبك DataCols = Array("B", "C", "D") ' قم بتحديد الأعمدة المرحل اليها DestCols = Array("B", "C", "D") 'Code............ If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى", vbExclamation GoTo Cleanup End If f = True For j = LBound(DataCols) To UBound(DataCols) lastRow = ws.Cells(ws.Rows.Count, DataCols(j)).End(xlUp).Row Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & lastRow) If Application.WorksheetFunction.CountA(DataRng) > 0 Then f = False destCol = dest.Columns(DestCols(j)).Column With dest.Range(dest.Cells(5, destCol), dest.Cells(dest.Rows.Count, destCol)) .ClearContents .ClearFormats End With Set destRng = dest.Range(dest.Cells(5, destCol), _ dest.Cells(lastRow, destCol)) destRng.value = DataRng.value DataRng.Copy destRng.PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False End If Next j If f Then MsgBox WSname & " لا يوجد بيانات للنسخ في جميع الأعمدة المحددة", vbExclamation GoTo Cleanup End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى شهر " & destName & " بنجاح:", vbInformation Cleanup: Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume Cleanup End Sub وكما جاء في طلبك الاول بمعني ترحيل الاعمده b5:b200و c5:c200 و d5:d200 بدلاً من تحديد آخر صف يحتوي على بيانات يمكنك استخدام النطاق الثابت بين الصفوف 5 و 200 For j = LBound(DataCols) To UBound(DataCols) ' تحديد النطاق الثابت من الصف 5 إلى الصف 200 Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & "200") If Application.WorksheetFunction.CountA(DataRng) > 0 Then f = False destCol = dest.Columns(DestCols(j)).Column With dest.Range(dest.Cells(5, destCol), dest.Cells(200, destCol)) .ClearContents .ClearFormats End With Set destRng = dest.Range(dest.Cells(5, destCol), dest.Cells(200, destCol)) destRng.value = DataRng.value DataRng.Copy destRng.PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False ترحيل على حسب المطلوب فى العمل.xlsm

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

جرب هدا =IF(EDATE(G2, -60) > G2, G2, EDATE(G2, -60))

أستاد محمد صالح ليس هناك ما يغضبني في هدا بالعكس هدفنا هنا هو مساعدة الاخوة الاعضاء فقط أما مسألة أفضل إجابة لن تضيف لي ولك أيضا على ما أعتقد أي شيئ لاكن ادا كانت هده من صلاحيات المشرفين لابد من الأخد في عين الإعتبار عدة عوامل في اختيارها مع إحترامي لك طبعا ليس كل من أجاب أولا فإقتراحه صائب ما جعلني ان اطرح السؤال هو تكرار الأمر عدة مرات ربما هنا اقتراحك ينفد المطلوب فعلا لاكن في عدة مشاركات للأسف يتم اختيارها عبثا مجرد اقتراح سبق التنويه اليه مسبقا الافضل ترك امكانية اختيارها لصاحب الموضوع هناك حالات استثنائية تم الرد منه كمثال (تم المطلوب )----(جزاك الله خيرا ) كما تعودنا دون اختياره لافضل اجابة في هده الحالة يحق للمشرفين وضعها وغلق الموضوع هدا يعطي مصداقية اكثر ولكم واسع النظر

هذا الكود سيحذف جميع الصفوف التي تحتوي على قيم غير فريدة في العمود المحدد بمعنى سيتم حذف جميع الصفوف التي تحتوي على قيم متكررة، بما في ذلك النسخة الأولى لكل قيمة 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

ولك بمثل مادعوت اخي @M.Elmahmoudy السؤال بما أنك لم تقم بزيارة المنتدى مند طرح طلبك من قام بإختيار أفضل إجابة ؟؟؟؟؟

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

تمام اخي بما أن الموضوع مختلف حاول فتح موضوع جديد بطلبك وإن شاء الله سنقوم بإنشاء أو تعديل الكود ليتناسب مع متطلباتك الجديدة بالتوفيق ..

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

وعليكم السلام ورحمة الله تعالى وبركاته سؤال غير واضح يجب دكر مكان تواجد البيانات المكررة هل عمود معين مثلا او نطاق او مادا .......

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

وعليكم السلام ورحمة الله تعالى وبركاته لاستخراجها في عمود مغاير يكفي استخدام المعادلة التالية =IF(A2<>"", "'" & A2, "") اما بالنسبة لاستخدام الأكواد يمكنك استخدام طريقة أكثر كفاءة واسرع خاصة عند وجود عدد كبير من البيانات من خلال تقليل عدد عمليات الكتابة إلى الخلايا. بدلاً من تعديل كل خلية فردياً في حلقة يمكنك استخدام مصفوفات لتخزين القيم مؤقتاً ثم كتابة البيانات مرة واحدة فقط مع ضمان عدم التعديل على الخلايا الفارغة Sub test() Dim f As Worksheet Dim tmp As Variant Dim i As Long, lastRow As Long Application.ScreenUpdating = False Set f = ThisWorkbook.Sheets("Sheet1") lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row tmp = f.Range("A2:A" & lastRow).Value For i = 1 To UBound(tmp, 1) If tmp(i, 1) <> "" Then tmp(i, 1) = "'" & tmp(i, 1) End If Next i f.Range("A2:A" & lastRow).Value = tmp Application.ScreenUpdating = True End Sub Copy of OverTime.xlsb

وهدا للتقسيم بشرط خلية معينة مثلا E1 يمكنك تعديلها بما يناسبك Sub test2() Dim f As Worksheet, newWb As Workbook Dim DataRng As Range, newWs As Worksheet Dim rowCount As Long, startRow As Long, endRow As Long Dim rowLimit As Long Dim WSname As String, folderPath As String Dim Cnt As Long, FolderName As String On Error GoTo ErrorHandler With Application .ScreenUpdating = False .DisplayAlerts = False .CopyObjectsWithCells = False End With Set f = ThisWorkbook.Sheets(1) rowCount = f.Cells(f.Rows.Count, "A").End(xlUp).Row startRow = 2 Cnt = 0 FolderName = "تقسيم" folderPath = ThisWorkbook.Path & "\" & FolderName & "\" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If ' خلية تحديد عدد الصفوف rowLimit = f.Range("E1").Value Do While startRow <= rowCount endRow = startRow + rowLimit - 1 If endRow > rowCount Then endRow = rowCount Set DataRng = f.Range("A" & startRow & ":D" & endRow) Set newWb = Workbooks.Add Set newWs = newWb.Sheets(1) f.Range("A1:D1").Copy newWs.Range("A1:D1") DataRng.Copy newWs.Range("A2") For col = 1 To f.Cells(1, f.Columns.Count).End(xlToLeft).Column newWs.Columns(col).ColumnWidth = f.Columns(col).ColumnWidth Next col WSname = "Part_" & " " & (startRow - 1) & "-" & (endRow - 1) & ".xlsx" newWb.SaveAs folderPath & WSname newWb.Close False startRow = endRow + 1 Cnt = Cnt + 1 Loop With Application .ScreenUpdating = True .DisplayAlerts = True .CopyObjectsWithCells = True End With MsgBox "تم استخراج " & Cnt & " ملف", vbInformation, "تقسيم الملفات" Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical, "خطأ" With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub

يسعدنا انك حصلت على طلبك اليك حل اخر للفائدة فقط مع نسخ الملفات في مجلد في نفس مسار الملف الرئيسي Sub SplitData() Dim f As Worksheet, newWb As Workbook Dim DataRng As Range, newWs As Worksheet Dim rowCount As Long, startRow As Long, endRow As Long Dim WSname As String, folderPath As String Dim Cnt As Long, FolderName As String On Error GoTo ErrorHandler With Application .ScreenUpdating = False .DisplayAlerts = False .CopyObjectsWithCells = False End With Set f = ThisWorkbook.Sheets(1) rowCount = f.Cells(f.Rows.Count, "A").End(xlUp).Row startRow = 2 Cnt = 0 FolderName = "تقسيم" folderPath = ThisWorkbook.Path & "\" & FolderName & "\" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If Do While startRow <= rowCount endRow = startRow + 29 If endRow > rowCount Then endRow = rowCount '******** قم بتعديل نطاق الاعمدة بما يناسبك Set DataRng = f.Range("A" & startRow & ":D" & endRow) Set newWb = Workbooks.Add Set newWs = newWb.Sheets(1) f.Range("A1:D1").Copy newWs.Range("A1:D1") DataRng.Copy newWs.Range("A2") For col = 1 To f.Cells(1, f.Columns.Count).End(xlToLeft).Column newWs.Columns(col).ColumnWidth = f.Columns(col).ColumnWidth Next col WSname = "Part_" & " " & (startRow - 1) & "-" & (endRow - 1) & ".xlsx" newWb.SaveAs folderPath & WSname newWb.Close False startRow = endRow + 1 Cnt = Cnt + 1 Loop With Application .ScreenUpdating = True .DisplayAlerts = True .CopyObjectsWithCells = True End With MsgBox "تم استخراج " & Cnt & " ملف", vbInformation, "تقسيم الملفات" Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical, "خطأ" With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا بمكنك حدف السطور المخصصة للتحقق من أوراق العمل في حالة الرغبة لاختصار الكود Sub test1() Dim DataRng As Range, arr As Variant Dim Ct As Long, i As Long, tmp As Boolean Dim ws As Worksheet, dest As Worksheet Dim WSname As String, destName As String '****التحقق من وجود ورقة العمل المرغوب الترحيل منها 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 '***** نطاق البيانات Set DataRng = ws.Range("B5:B200") tmp = Application.WorksheetFunction.CountA(DataRng) > 0 If Not tmp Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في شهر", vbExclamation Exit Sub End If '****افراغ البيانات السابقة dest.Range("B5:B200").ClearContents ReDim arr(1 To DataRng.Rows.Count, 1) Ct = 0 For i = 1 To DataRng.Rows.Count If Len(DataRng.Cells(i, 1).Value) > 0 Then Ct = Ct + 1 arr(Ct, 1) = DataRng.Cells(i, 1).Value End If Next i ' لصق البيانات بداية من الصف 5 من ورقة الشهر المختارة If Ct > 0 Then For i = 1 To Ct dest.Range("B5").Offset(i - 1, 0).Value = arr(i, 1) Next i End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation End Sub ولنسخها بدون تكرار ستجد الكود داخل الملف المرفق ترحيل.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SansDoublons() Dim dict As Object, tmp As Variant Dim cell As Range, i As Long Dim f As Worksheet: Set f = Sheets("Sheet1") Dim WS As Worksheet: Set WS = Sheets("Sheet2") Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In f.Range("b5:b100") If Len(cell.Value) > 0 And Not dict.exists(cell.Value) Then dict.Add cell.Value, Nothing End If Next cell If dict.Count > 0 Then WS.Range("b5:b100").ClearContents tmp = dict.Keys For i = LBound(tmp) To UBound(tmp) WS.Cells(i + 5, 2).Value = tmp(i) Next i End If Application.ScreenUpdating = True End Sub لتشغيل الماكرو تلقائيا عند الغيير في عمود (b) ورقة 1 في حدث Sheet1 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("b5:b100")) Is Nothing Then SansDoublons End If End Sub نقل القيم بدون تكرار.xlsb

بارك الله فيك استاد @أ / محمد صالح كود جميل يمكننا استخدامه في حالة عدم الرغبة بالاحتفاظ بالارقام على القائمة الرئيسية الاصلية