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

وهدا للتقسيم بشرط خلية معينة مثلا 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

وعليكم السلام ورحمة الله وبركاته، نعم، يمكن القيام بذلك باستخدام VBA في Excel. إليك كود VBA الذي يمكنك استخدامه لتقسيم البيانات إلى ملفات منفصلة كل 30 صف: افتح ملف Excel واضغط على Alt + F11 لفتح محرر VBA. أدخل الكود التالي في وحدة جديدة: Sub SplitDataIntoFiles() Dim ws As Worksheet Dim newWs As Worksheet Dim wb As Workbook Dim newWb As Workbook Dim lastRow As Long Dim i As Long Dim j As Long Dim filePath As String Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من أن اسم الورقة صحيح lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row filePath = ThisWorkbook.Path & "\" j = 1 For i = 1 To lastRow Step 30 Set newWb = Workbooks.Add Set newWs = newWb.Sheets(1) ws.Rows(i & ":" & i + 29).Copy Destination:=newWs.Rows(1) newWb.SaveAs filePath & "Data_" & j & ".xlsx" newWb.Close SaveChanges:=False j = j + 1 Next i MsgBox "تم تقسيم البيانات بنجاح!",,"mr-mas.com" End Sub قم بتعديل اسم الورقة في السطر Set ws = ThisWorkbook.Sheets("Sheet1") إذا كان مختلفًا. اضغط على F5 لتشغيل الكود. سيقوم هذا الكود بتقسيم البيانات إلى ملفات منفصلة كل 30 صف وحفظها في نفس مسار الملف الأصلي. بالتوفيق

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

مبدئيا اعمل وحدة نمطية جديدة وسميها مثلا: basInputBoxWithMask ضع الاكواد الاتية بالوحدة النمطية Option Compare Database Option Explicit '********************************************************************** ' Module: MaskedInputBox ' Purpose: This module provides functionality to create an InputBox ' with masked input, displaying characters as asterisks (*) ' typically used for password entry. ' ' API Declarations: ' - CallNextHookEx: Passes the hook information to the next hook procedure in the current hook chain. ' - GetModuleHandle: Retrieves a module handle for the specified module. ' - SetWindowsHookEx: Installs a hook procedure into the hook chain. ' - UnhookWindowsHookEx: Removes a hook procedure installed in a hook chain. ' - SendDlgItemMessage: Sends a message to a control in a dialog box. ' - GetClassName: Retrieves the name of the class to which the specified window belongs. ' - GetCurrentThreadId: Retrieves the thread identifier of the calling thread. ' ' Constants: ' - EM_SETPASSWORDCHAR: Used to specify the character to be displayed when text is entered in a password field. ' - WH_CBT: Hook type for monitoring and modifying Computer-Based Training (CBT) events. ' - HCBT_ACTIVATE: Hook code that is sent when a window is about to be activated. ' - HC_ACTION: Indicates a valid action has taken place, allowing processing to continue. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** #If VBA7 Or Win64 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As Any) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long #Else Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long #End If ' Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 #If VBA7 Or Win64 Then Private hHook As LongPtr #Else Private hHook As Long #End If '********************************************************************** ' Function: NewProc ' Purpose: This function is the hook procedure that processes CBT ' events, specifically to mask input characters in an InputBox. ' Inputs: ' - lngCode: The code of the event (Long). ' - wParam: A handle to the window related to the event (Long). ' - lParam: Pointer to an event-specific structure (Long). ' Returns: - LongPtr: The result from the next hook procedure or 0 if handled. ' Notes: ' - Only processes events with code >= HC_ACTION. ' - Checks for dialog box activation and sets the password character. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr Dim strClassName As String Dim lngBuffer As Long Dim result As Long ' Proceed only if the message code is an action code If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If ' Get the class name of the window being activated strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then result = GetClassName(wParam, strClassName, lngBuffer) ' Check if the class name is a dialog box ("#32770") If Left$(strClassName, result) = "#32770" Then ' Set the character for password masking SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If ' Call the next hook in the chain and return its value NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) End Function '********************************************************************** ' Function: InputBoxDK ' Purpose: Displays an InputBox with masked input, showing each character ' as an asterisk (*) instead of the actual character. ' Inputs: ' - Prompt: The prompt string displayed in the InputBox (String). ' - Optional Title: The title of the InputBox window (String). ' - Optional Default: The default string displayed in the InputBox (String). ' - Optional XPos: The x-coordinate of the InputBox (Long). ' - Optional YPos: The y-coordinate of the InputBox (Long). ' - Optional HelpFile: The name of the Help file for the InputBox (String). ' - Optional Context: The Help context number for the InputBox (Long). ' Returns: - String: The string entered by the user in the InputBox. ' Notes: ' - Hooks into the CBT events to mask the input as the user types. ' - The hook is removed after the InputBox is closed to prevent resource leaks. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Function InputBoxDK(Prompt As String, Optional Title As String, Optional Default As String, Optional XPos As Long, Optional YPos As Long, Optional HelpFile As String, Optional Context As Long) As String On Error GoTo ExitProperly Dim lngModHwnd As LongPtr Dim lngThreadID As Long ' Get the current thread ID and module handle lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) ' Set the hook for CBT (Computer-Based Training) to monitor and modify dialog box creation hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) ' Show the InputBox InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) ExitProperly: ' Ensure the hook is removed to prevent resource leaks If hHook <> 0 Then UnhookWindowsHookEx (hHook) End Function بالنسبة للنموذج دى الاكواد وطبعا لا انصح باستخدام اللغة العربية داخل المحرر Option Compare Database Option Explicit Private Sub Command4_Click() DoCmd.GoToRecord , , acNewRec End Sub '********************************************************************** ' Subroutine: Checkbox_AfterUpdate ' Purpose: Toggles the InputMask property of a password input field based on the state of a checkbox. ' When the checkbox is checked, the password is displayed as plain text; ' when unchecked, the password is masked with the "Password" mask. ' Inputs: ' - None (uses the current state of the form's controls). ' Outputs: ' - None (modifies the InputMask property of the "pass" control). ' Notes: ' - This subroutine assumes that "Checkbox" is a control on the form and is tied to ' the user's action of toggling the checkbox. ' - If the checkbox is checked (True), the password will be shown in plain text. ' - If unchecked (False), the password will be masked. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Private Sub Checkbox_AfterUpdate() ' Check the value of the checkbox and update the InputMask of the "pass" field accordingly If Me.Checkbox.Value = True Then Me.pass.InputMask = "" ' Show the password as plain text Else Me.pass.InputMask = "Password" ' Mask the password with the "Password" input mask End If End Sub '********************************************************************** ' Subroutine: jop_AfterUpdate ' Purpose: Validates the job role entered by the user and enforces role-specific constraints. ' If the job role is "مستخدم" (User), it checks if the maximum allowed number of ' users has been reached. If so, it prompts for a password to allow adding more users. ' Inputs: ' - None (uses the current state of the form's controls). ' Outputs: ' - None (may prevent form submission based on validation checks). ' Notes: ' - The subroutine assumes "jop" is a control on the form where the user selects their job role. ' - If the job role is not "محاسب" (Accountant) or "مستخدم" (User), an error message is shown, ' and the action is canceled. ' - If the job role is "مستخدم", the subroutine checks the number of existing users in the database. ' If there are already 3 users, the subroutine prompts for a password before allowing more users to be added. ' - The password required to add more users is hardcoded as "123". This should be secured in a production environment. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Private Sub jop_BeforeUpdate(Cancel As Integer) Dim db As DAO.Database Dim rs As DAO.Recordset Dim UserCount As Integer Dim PasswordInput As String ' Get the current database Set db = CurrentDb() ' Validate the job role entered by the user If Me.jop.Value <> "محاسب" And Me.jop.Value <> "مستخدم" Then MsgBox "برجاء إدخال كلمة محاسب أو مستخدم فقط.", vbExclamation, "قيمة غير صحيحة" Cancel = True Exit Sub End If ' If the job role is "مستخدم", check the number of existing users If Me.jop.Value = "مستخدم" Then Set rs = db.OpenRecordset("SELECT COUNT(*) AS CountOfUsers FROM tblUsers WHERE jop = 'مستخدم'") UserCount = rs!CountOfUsers ' If the maximum number of users has been reached, prompt for a password If UserCount >= 3 Then PasswordInput = InputBoxDK("لقد تم إدخال 3 سجلات لمستخدمين. يرجى إدخال كلمة السر لإضافة مستخدم جديد:") ' Validate the entered password If PasswordInput = "" Or PasswordInput <> "123" Then MsgBox "كلمة السر غير صحيحة. لا يمكن إضافة مستخدم جديد.", vbExclamation Cancel = True End If End If rs.Close Set rs = Nothing End If ' Clean up Set db = Nothing End Sub

باشمهندس @ابو جودي نعم استاذى عاوز كلمة السر مع inputbox الله يفتح عليك يا ابنى

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

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

فعلا عمل جميل يسلم ايدك ابا جودي

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

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

أ / محمد صالح بارك الله فيك أخي الكريم، تمت العملية على ما يرام، والتقسيم حسب المطلوب تماماً. أشكر لك سرعة الاستجابة، أدعو الله في عليائه أن ييسر أمركم، ويجعل هذا العمل في ميزان حسناتكم إلى يوم الدين دمتم بخير أ. محمد هشام بارك الله فيك، وعلى مبادرتكم الطيبة والسرعة في الرد، ما شاء الله تبارك الرحمن. تم استخدام الكود الذي أرسله أ. محمد صالح، والأمور سارت على ما يرام. أشكر لك جهودك الطيبة دمتم بخير

جرب استعمال هذا الكود For Each cell In range("a2:a10000") cell.Value = "'" & cell.Value Next cell بالتوفيق

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

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

طبعا لا بد من وجود علاقة بين الجدولين وتصميمك للحقول صحيح Database3.rar

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

بارك الله فيكم جميعا ولإثراء الموضوع وتحقيقا لهوايتي المفضلة اختصار الأكواد يمكنك أخي صاحب الاستفسار أن تضع هذا الكود مكان الإجراء القديم Sub REs_Data() lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("CAll").Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr myval = Evaluate("=IFERROR(INDEX(CAll!$C$2:$C$" & lr2 & ",MATCH(B" & r & ",CAll!$A$2:$A$" & lr2 & ",0)),"""")") Range("E" & r).value = IIf(myval = "", Range("E" & r).value, myval) Next r MsgBox "Done by mr-mas.com", , "M.A.S" End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub UpdateDates() ' تعريف المتغيرات Dim WS As Worksheet, f As Worksheet Dim a As Variant, b As Variant Dim lr As Long, Irow As Long Dim i As Long, j As Long Set WS = ThisWorkbook.Sheets("CALL") Set f = ThisWorkbook.Sheets("DATA") '*** (lr) Sheets("CALL")<<====("a") تحديد آخر صف غير فارغ في العمود lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row '*** (Irow) Sheets("DATA")<<====("B") تحديد آخر صف غير فارغ في العمود Irow = f.Cells(f.Rows.Count, "B").End(xlUp).Row '***تخزين البيانات في المتغيرات*** '(A2)البيانات من النطاق Sheets("DATA")<<==== (a)تُخزن في المتغير a = WS.Range("A2:E" & lr).Value '(A2)البيانات من النطاق Sheets("CALL")<<==== (b)تُخزن في المتغير b = f.Range("A2:E" & Irow).Value '******التكرار عبر الصفوف****** ' يتم استخدام حلقتين تكراريتين For لتصفح البيانات في كل من المصفوفتين a و b 'b Sheets("DATA")<<===='الأولى تكرر عبر الصفوف في البيانات المخزنة For i = 1 To UBound(b, 1) 'a Sheets("CALL")<<===='الثانية تكرر عبر الصفوف في البيانات المخزنة For j = 1 To UBound(a, 1) '*****التحقق من المطابقة **** 'داخل الحلقة الثانية يتم التحقق من شرطين '1======= Sheets("CALL")====>> (b) إذا كانت القيمة في العمود الثاني من ' Sheets("DATA")====>> (a) تساوي القيمة في العمود الأول من '2======= Sheets("DATA")====>> (a) وإذا كانت القيمة في العمود الثالث من ' Sheets("CALL")====>> (b) تساوي القيمة في العمود الثاني من If b(i, 2) = a(j, 1) And b(i, 3) = a(j, 2) Then 'Sheets("DATA") إذا تحقق الشرطان، يتم تحديث الخلية في العمود الخامس من 'Sheets("CALL") بالقيمة المقابلة في العمود الثالث من f.Cells(i + 1, 5).Value = a(j, 3) '(Exit For)الخروج من الحلقة 'يتم استخدامه للخروج من الحلقة الداخلية عند العثور 'على تطابق مما يوفر الوقت ويجعل الكود أكثر كفاءة Exit For End If Next j Next i End Sub نموذج V1.xlsm

بارك الله فيك اخى

اخي الفاضل مربع inputbox في Excel لا يدعم إخفاء كلمة السر أو إظهارها كنجوم أو علامات. هو ببساطة يعرض مربع حوار لإدخال النص دون تقديم خيارات لتنسيق العرض مثل إخفاء النص. لإخفاء كلمة السر أو إظهارها كنجوم، يجب عليك استخدام Userform الذي يتيح لك تخصيص واجهة المستخدم بشكل أكبر. يمكنك استخدام خاصية PasswordChar لمربع النص (Textbox) لعرض كلمات المرور كنجوم أو أي رمز آخر تختاره بعد معاينة الكود الخاص بك حاولت تجربة انشاء شاشة دخول بسيطة بنفس الفكرة مع اظافة بعض التحسينات على الكود وطريقة اشتغالك على الملف مع اظافة ورقة خاصة بتسجيل الزوار باسم AccessLog لتتبع المستخدمين والمدة المستغرقة في استخدام الملف هدا مجرد اقتراح بسيط للفائدة فقط اليك الكود مع الشرح لتتمكن من تعديله بما يناسبك Private Sub UserForm_Initialize() Set f = Sheets("list") Set MonDico = CreateObject("Scripting.Dictionary") ' قراءة القيم من العمود L، بدءًا من الخلية L2 حتى آخر خلية بها بيانات a = f.Range("l2:l" & f.[L65000].End(xlUp).Row).Value For i = LBound(a) To UBound(a) ' إضافة القيم غير الفارغة إلى Dictionary (القيم الفريدة فقط) If a(i, 1) <> "" Then MonDico(a(i, 1)) = "" Next i Me.ComboBox1.List = MonDico.keys End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet, logWs As Worksheet Dim lrow As Long, clé As String Dim password As String, Xtime As String Static AttemptCount As Integer, username As String ' تعيين ورقة العمل "list" Set ws = ThisWorkbook.Sheets("list") ' تعيين ورقة العمل للتسجيل Set logWs = ThisWorkbook.Sheets("AccessLog") ' الحصول على اسم المستخدم من ComboBox username = ComboBox1.Value ' التحقق إذا كان اسم المستخدم مدخل If username = "" Then MsgBox "يرجى اختيار اسم المستخدم.", vbExclamation Exit Sub End If ' العثور على آخر صف يحتوي على بيانات في العمود 12 (L) lrow = ws.Cells(ws.Rows.Count, 12).End(xlUp).Row ' البحث عن كلمة السر المرتبطة بالاسم For i = 2 To lrow If ws.Cells(i, 12).Value = username Then password = ws.Cells(i, 13).Value Exit For End If Next i ' الحصول على كلمة السر المدخلة من مربع النص clé = TextBox1.Text ' التحقق إذا كانت كلمة السر المدخلة صحيحة If clé = password Then ' تسجيل الدخول الناجح With logWs ' العثور على آخر صف فارغ في الأعمدة A, B, C و D lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Cells(lrow, 1).Value = username .Cells(lrow, 2).Value = Date .Cells(lrow, 3).Value = Format(Time, "hh:mm:ss") ' توقيت الدخول فقط كوقت .Cells(lrow, 4).Value = "دخول ناجح" ' إضافة رسالة تسجيل الدخول الناجح End With ' عرض رسالة ترحيب MsgBox "مرحبا " & username & "، لقد تم تسجيل الدخول بنجاح!", vbInformation ' إظهار Excel Application.Visible = True ' إغلاق UserForm Unload Me ' إعادة تعيين عدد المحاولات AttemptCount = 0 Else ' معالجة الدخول الفاشل AttemptCount = AttemptCount + 1 If AttemptCount >= 3 Then MsgBox "لقد تجاوزت عدد المحاولات المسموح بها. سيتم حفظ وإغلاق الملف.", vbExclamation ThisWorkbook.Save Application.Quit Else MsgBox "الرجاء التأكد من كلمة السر! المحاولة " & AttemptCount & " من 3" Me.TextBox1.Text = "" End If End If End Sub Private Sub CommandButtonClose_Click() Dim answer As VbMsgBoxResult answer = MsgBox("هل أنت متأكد من الخروج من البرنامج؟", vbYesNo + vbQuestion, "تأكيد الإغلاق") If answer = vbYes Then ' حفظ المصنف ThisWorkbook.Save ' إغلاق المصنف ThisWorkbook.Close SaveChanges:=False Application.Quit End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True MsgBox "يرجى استخدام زر الإغلاق المخصص لإغلاق النموذج", vbInformation End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub '**************************************** Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim logWs As Worksheet Dim lrow As Long Dim currentTime As Date Dim entryTime As Date On Error Resume Next Set logWs = ThisWorkbook.Sheets("AccessLog") If logWs Is Nothing Then MsgBox "ورقة العمل 'AccessLog' غير موجودة.", vbExclamation Exit Sub End If ' الحصول على الوقت الحالي currentTime = Now ' العثور على آخر صف يحتوي على بيانات lrow = logWs.Cells(logWs.Rows.Count, 1).End(xlUp).Row ' التحقق إذا كان هناك سجل سابق لتوقيت الدخول If lrow > 1 Then ' الحصول على توقيت الدخول entryTime = logWs.Cells(lrow, 3).Value ' تسجيل توقيت الخروج With logWs .Cells(lrow, 4).Value = Format(currentTime, "hh:mm:ss") ' توقيت الخروج فقط كوقت End With End If On Error GoTo 0 ' إلغاء التعامل مع الأخطاء ' حفظ المصنف ThisWorkbook.Save ' إغلاق المصنف ThisWorkbook.Close SaveChanges:=False ' تأكد من إغلاق المصنف بشكل صحيح ' إذا كنت تريد إغلاق Excel بالكامل، استخدم: 'Application.Quit End Sub عند الانتهاء من تعديل برنامجك حاول وضع باسوورد لمحرر الاكواد تفاديا للتلاعب بها كلمات المرور واسماء المستخدمين الحالية كما في الصورة فوق بالتوفيق.... شاشة دخول.xlsb

مبعدع وفنان يا فنان تسلم على الهديه الرائعه بش مهندس محمد

بسم الله ما شاء الله ابدعت وهتخلينى افكر بطريقه مختلفه تسلم يا هندسه استاذي @Moosak ضيفها فى المكتبه العامره الله يبارك فيك

أنت مبدع يا باش مهندس @ابو جودي 😀👌 وأنا طبعا ما قدمت إلا لمسات بسيطة والجهد كله من إبداعاتك يا فنان 😎🌹 ربنا يوفقك ويبارك فيك 👐🏻

للعلم تم عمل تحديثات جديدة للواجهة : قمت بتطوير النموذج ليحمل أزرار فرعية وأزرار فرعية من الفرعية بناءا على طلب بعض الإخوة 🙂 كما تم إضافة خاصية إمكانية فتح الماكرو للأزرار .. وكذلك مع إمكانية فتح النماذج والتقارير في وضع التكبير Maximize .. وهذه صورة للوحة التحكم : ملاحظة : تم تحديث رابط التحميل في المشاركة الأولى 🙂

بسم الله الرحمن الرحيم قمت بهذا العمل وأتمنى أن ينال إعجابكم تظهر الصور جميعاً ثم بالنقر على أى منها تكبر ثم تنتقل إلى مكان مخصص لها __________.rar