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

انا اردت ان تأخذ الفكرة والتي هي استخدام مربع تص بدلا من صندوق الرسالة وتعديل بسيط على كود الأستاذ القدير أزهر لتحويل الصندوق الى حقل يتحقق المطلوب On Error GoTo Err_Dell_Click_Error If Me.TextPass.Visible = False Then Me.TextPass.Visible = True Beep MsgBox "ادخل كلمة المرور", vbOKOnly, _ "Important Information" Exit Sub End If If Me.TextPass = "12345" Then DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdDeleteRecord Me.TextPass.Visible = False MsgBox "تم الحذف", vbOKOnly, _ "Important Information" Else Beep MsgBox "ليس لك الحق بالوصول", vbOKOnly, _ "Important Information" Me.TextPass.Visible = False Exit Sub End If Exit_Err_Dell: Exit Sub Err_Dell_Click_Error: If Err.Number = 2001 Then Resume Exit_Err_Dell End If base_pass.rar

وعليكم السلام ورحمة الله تعالى وبركاته اظن ان اقتراح الاخ @عبدالله بشير عبدالله سيوفي بالغرض ولإثراء الموضوع إليك بعض الحلول الأخرى =IF(I2<>"",MAX(IF($F$2:$F24=I2,$E$2:$E24)),"") =IF(I2<>"",TEXT(AGGREGATE(14,6,$E$2:$E24/($F$2:$F24=I2),1),"DD/MM/YYYY"),"") =IF(I2<>"", XLOOKUP(I2, $F$2:$F24, $E$2:$E24, "", 0, -1), "") =IF(I2<>"", IFERROR(TEXT(AGGREGATE(14,6,$E$2:$E24/($F$2:$F24=I2),1),"DD/MM/YYYY"),"لا توجد بيانات"), "") =IF(I2<>"", MAX(FILTER($E$2:$E24, $F$2:$F24=I2)), "")

انا اتكلم من واقع برامج قائمة .. لو بحثت في المنتدى لوجدت الكثير من الامثلة يتم فيها تطبيق ما ذكرته اعلاه ابحث مثلا في : تشفير كلمة المرور .. ابحث في الحقل الخاص بــــ google

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

يمكنك استخدام كود VBA في Excel لتحقيق ذلك. إليك مثال على كود يمكنك تعديله حسب الحاجة: Sub CopyColumns() Dim sourceSheet As Worksheet Dim targetSheet As Worksheet Dim sourceRange As Range Dim targetRange As Range ' تحديد الورقة المصدر والورقة الهدف Set sourceSheet = ThisWorkbook.Sheets("SourceSheetName") Set targetSheet = ThisWorkbook.Sheets("TargetSheetName") ' نسخ العمود B Set sourceRange = sourceSheet.Range("B5:B200") Set targetRange = targetSheet.Range("B5") sourceRange.Copy Destination:=targetRange ' نسخ العمود C Set sourceRange = sourceSheet.Range("C5:C200") Set targetRange = targetSheet.Range("C5") sourceRange.Copy Destination:=targetRange ' نسخ العمود D Set sourceRange = sourceSheet.Range("D5:D200") Set targetRange = targetSheet.Range("D5") sourceRange.Copy Destination:=targetRange End Sub يمكنك تعديل أسماء الأوراق والنطاقات حسب الحاجة. إذا كنت ترغب في تغيير الأعمدة المرحل إليها، يمكنك تعديل القيم في `targetRange`. بالتوفيق