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

وعليكم السلام ورحمة الله وبركاته الملف به ثلاث خانات للبحث (تمت اضافة الوحدة كعنصر للبحث .. لأنكم لم تحددوا ما العمود المطلوب البحث فيه) مع اجتهاد بسيط بوضع البيانات الأساسية في ورقة (Prime). بحث بشرطين.xlsm

السلام عليكم ورحمة الله تعالى وبركاته طبعا لن اضع افكارى صريحة لتطبيق فكرة محددة لا أنوى أن اعطيكم سمكا بل انوى أن أعلمكم الصيد ... لذلك سوف اضع الاكواد والافكار على وجه العموم وعلى سبيل الشرح ليس الا وليدل كل منكم بدلوه فى التطبيق وليستحضر بنات افكاره كما يترأى له 1- الحماية عن طريق اضافة بيانات الحماية فى الريجسترى نستخدم الأكواد الاتية فى وحدة نمطيه التطبيق فى القاعدة المرفقة .. تم وضع بعض التلميحات على الأكواد Public Const MyRegPath As String = "HKEY_CURRENT_USER\Software\Officena.net" Public Const MyRegKey As String = "Judy" Public Const myStringValue As String = "محمد" Public Const myValueData As String = "ابو جودى" 'returns True if the registry key i_RegKey was found 'and False if not Function RegKeyExists(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'try to read the registry key myWS.RegRead i_RegKey 'key was found RegKeyExists = True Exit Function ErrorHandler: 'key was not found RegKeyExists = False End Function Function RegKeyRead(i_RegKey As String) As String Dim myWS As Object On Error Resume Next 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'read key from registry RegKeyRead = myWS.RegRead(i_RegKey) End Function Function RegKeySave(i_RegKey As String, _ i_Value As String, _ Optional i_Type As String = "REG_SZ") Dim myWS As Object 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'write registry key myWS.RegWrite i_RegKey, i_Value, i_Type End Function Function RegKeyDelete(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'delete registry key myWS.RegDelete i_RegKey 'deletion was successful RegKeyDelete = True Exit Function ErrorHandler: 'deletion wasn't successful RegKeyDelete = False End Function يتبع.. القاعدة المرفقة 01-Dealing with the registry.accdb

3- استخلاص قيم من مكونات الجهاز تستخدم فى عملية الترخيص - رقم الـ UUID رقم ثابت لا يتغير بتغيير الهارد ديسك او ختى بعملية الفورمات أو إعادة التقسيم للهارد ديسك - Public Function GetUUID(Optional strHost As String = ".") As String On Error GoTo ErrorHandler Dim objComputerSystemProduct As Object Dim objWMIService As Object Dim objItems As Object Dim objDiskDriveSerial As Object Set objWMIService = GetObject("winmgmts:\\" & strHost & "\root\cimv2") Set objComputerSystemProduct = objWMIService.ExecQuery("Select * from Win32_ComputerSystemProduct", , 48) For Each objItems In objComputerSystemProduct GetUUID = objItems.UUID Next Set objItems = Nothing Set objWMIService = Nothing Set objComputerSystemProduct = Nothing ExitHandler: On Error Resume Next If Not objItems Is Nothing Then Set objItems = Nothing If Not objDiskDriveSerial Is Nothing Then Set objDiskDriveSerial = Nothing If Not objWMIService Is Nothing Then Set objWMIService = Nothing Exit Function ErrorHandler: MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: GetUUID" & vbCrLf & _ "Error Description: " & Err.Description, _ vbCritical, "An Error has Occurred!" Resume ExitHandler End Function - ويتم استدعاءه فقط من خلال GetUUID() - رقم وموديل الهارد ديسك ثابت ولا يتغير Public Function GetDDSerialNumber(Optional strHost As String = ".", Optional strSymbol As String = ",") As String On Error GoTo ErrorHandler Dim objComputerSystemProduct As Object Dim objWMIService As Object Dim objItems As Object Dim objDiskDriveSerial As Object Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strHost & "\root\cimv2") Set objDiskDriveSerial = objWMIService.ExecQuery("SELECT DeviceID, SerialNumber FROM Win32_DiskDrive") For Each objItems In objDiskDriveSerial GetDDSerialNumber = Trim(GetDDSerialNumber) & Trim(objItems.SerialNumber & strSymbol) Next If Right(GetDDSerialNumber, 1) = strSymbol Then GetDDSerialNumber = Left(GetDDSerialNumber, Len(GetDDSerialNumber) - 1) Set objItems = Nothing Set objWMIService = Nothing Set objDiskDriveSerial = Nothing ExitHandler: On Error Resume Next If Not objItems Is Nothing Then Set objItems = Nothing If Not objDiskDriveSerial Is Nothing Then Set objDiskDriveSerial = Nothing If Not objWMIService Is Nothing Then Set objWMIService = Nothing Exit Function ErrorHandler: MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: GetDDSerialNumber" & vbCrLf & _ "Error Description: " & Err.Description, _ vbCritical, "An Error has Occurred!" Resume ExitHandler End Function -ويتم فقط استدعاءه من خلال GetDDSerialNumber() التطبيق فى القاعدة المرفقة .. يتبع ... 3- ارقام القطع UUID - HDD.accdb

2-تشفير البيانات نستخدم الأكواد الاتية فى وحدة نمطيه Function incode(A As String, b As String) As String Dim r, i As Integer, s, u As String 1: u = "" s = ctrs(A, 3) If Len(s) Mod 2 = 1 Then s = s + Trim(Str(Int(8 * Rnd(-Timer)))) i = 3 * Rnd(-Timer) + 1 For r = 1 To i u = Chr(100 * Rnd(-Timer) + 155) + u Next u = Trim(Str(i)) + u u = u + s u = getcode(u, b) If decode(u, b) = A Then incode = u Else GoTo 1: End If End Function Function decode(A, b As String) As String On Error Resume Next Dim r, i As Integer, s, u As String u = getcode(A, b) i = Val(Mid(u, 1, 1)) + 1 u = Mid(u, i + 1, Len(u) - i) If Len(u) Mod 3 <> 0 Then u = Mid(u, 1, Len(u) - 1) s = "" For r = 1 To Len(u) - 2 Step 3 s = s + Chr(Val(Mid(u, r, 3))) Next decode = s End Function Function getcode(A, b As String) As String On Error Resume Next Dim L, r As Integer, c As Long, q As String c = 0 For r = 1 To Len(b) c = c + Asc(Mid(b, r, 1)) * (10 ^ r) Next q = Str(c) c = 0 For r = 1 To Len(q) c = c + Val(Mid(q, r, 1)) Next q = "" For r = 1 To Len(A) L = 256 - Asc(Mid(A, r, 1)) - r - Len(A) If L + c > 255 Then q = q + Chr(L - c) Else q = q + Chr(L + c) End If Next getcode = q End Function Function ctrs(s As String, y As Byte) As String Dim r, i As Integer, u, T As String u = "" For r = 1 To Len(s) T = Trim(Str(Asc(Mid(s, r, 1)))) For i = 1 To y - Len(T) T = "0" + T Next i u = u + T Next ctrs = u End Function التطبيق فى القاعدة المرفقة .. يتبع ... 02-Encode Decode.accdb

تفضل أخي عمل بسيط وأنت طوره فيما تريد أو ارسل مرفقك للعمل عليه , ووافني بالرد. d115.accdb

العفو اخي الكريم بما انني استطعت استعاب المطلوب اليك الكود النهائي للملف ربما اسرع عند انشاء عدد كبير من اوراق العمل Public Sub MH_2() Dim ws As Worksheet, WS1 As Worksheet Dim arr As Variant, MH1 As Variant Dim lngArr As Long, lr As Long Dim MH2 As String Dim rngCell As Range temps = Timer 'باستثناء الاوراق التالية MH2 = "Vehicle,Data,Sample" Set WS1 = Sheet1 lr = WS1.Range("H" & WS1.Rows.Count).End(xlUp).Row arr = WS1.Range("H2:H" & lr).Value Application.ScreenUpdating = False ' اظهار النمودج Sheet2.Visible = True 'حدف اوراق العمل For Each ws In Worksheets If InStr(1, MH2, ws.Name) = 0 Then MH1 = Application.Match(ws.Name, arr, 0) If IsError(MH1) Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If End If Next ws ' نسخ For lngArr = LBound(arr) To UBound(arr) If Len(Trim(arr(lngArr, 1))) > 0 Then If Not Evaluate("ISREF('" & arr(lngArr, 1) & "'!A1)") Then Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count) ActiveSheet.Name = arr(lngArr, 1) ' تسمية اوراق العمل Range("i19").Value = arr(lngArr, 1) '("i19") اضافة اسم ورقة العمل للخلية ' End If End If Next lngArr ' حدف الارتباطات السابقة With Sheet1 .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents Set rngCell = .Range("B2") End With 'إنشاء ارتباطات تشعبية على بيانات الاوراق الجديدة For Each ws In ActiveWorkbook.Worksheets If InStr(1, MH2, ws.Name) = 0 Then rngCell.Hyperlinks.Add Anchor:=rngCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name Set rngCell = rngCell.Offset(1) End If Next ws Set rngCell = Nothing Set WS1 = Nothing ' اخفاء النمودج Sheet2.Visible = False Sheet1.Activate Application.ScreenUpdating = True MsgBox "تم انشاء" & " " & Application.Sheets.Count - 3 & " " & "ورقة عمل جديدة " & "-" & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000") & "ثانية", Exclamation, "Officena" End Sub Personal_V2.xlsm

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

اعتقد تحتاج تنزيل Access Runtime

تم .. ترتيب الطلاب (٥).xls

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_SelectionChange(ByVal Target As Range) StartColumn = 6 ' اول عمود LastColumn = 40 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn Application.ScreenUpdating = False If Range("b20").Value = "" Then Columns("F:H").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i End Sub كود اخفاء.xlsm

السلام عليكم ورحمة الله تعالى وبركاته عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ المرفق الاتى ان شاء الله به حل المشكلة تماما طيب ما الفرق بين عمل الاكواد مع خاصية PopUp ان كانت PopUp = True يتم توسيط داخل الشاشة نفسها تبعا لابعاد شاشة العرض نفسها مهما اختلف مقاس الشاشة اما ان كان PopUp = False يتم التوسيط داخل اطار تطبيق الاكس نفسه الاكواد كالاتى اولا كلاس ولابد ان يكون اسم الكلاس clsAutoCenter وان احببتم تغيير الاسم فيجب تعديله فى الاكواد التى تخص الموديول بنفس الاسم الجديد اولا الكلاس : clsAutoCenter '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT 'RECT structure used for API calls. Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI 'POINTAPI structure used for API calls. X As Long Y As Long End Type Private m_hWnd As Long 'Handle of the window. Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window. Private Const m_ERR_INVALIDHWND = 1 Private Const m_ERR_NOPARENTWINDOW = 2 #If VBA7 Then Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long 'Returns the handle of the parent window of the specified window. #Else Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long 'Returns the handle of the parent window of the specified window. #End If Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String) 'Raises a user-defined error to the calling procedure. Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc End Sub Private Sub UpdateWindowRect() 'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow. Dim ptCorner As POINTAPI If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates. If Not Me.Parent Is Nothing Then 'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Left .Y = m_rctWindow.Top End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Left = ptCorner.X .Top = ptCorner.Y End With 'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Right .Y = m_rctWindow.Bottom End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Right = ptCorner.X .Bottom = ptCorner.Y End With End If Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Sub Public Property Get hWnd() As Long 'Returns the value the user has specified for the window's handle. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then hWnd = m_hWnd Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let hWnd(ByVal lngNewValue As Long) 'Sets the window to use by specifying its handle. 'Only accepts valid window handles. If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then m_hWnd = lngNewValue Else RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle." End If End Property Public Property Get Left() As Long 'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Left = m_rctWindow.Left Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Left(ByVal lngNewValue As Long) 'Moves the window such that its left edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Top() As Long 'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Top = m_rctWindow.Top Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Top(ByVal lngNewValue As Long) 'Moves the window such that its top edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Width() As Long 'Returns the current width (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Width = .Right - .Left End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Width(ByVal lngNewValue As Long) 'Changes the width of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Height() As Long 'Returns the current height (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Height = .Bottom - .Top End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Height(ByVal lngNewValue As Long) 'Changes the height of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Get Parent() As clsAutoCenter 'Returns the parent window as a clFormWindow object. 'For forms, this should be the Access MDI window. Dim fwParent As New clsAutoCenter Dim lngHWnd As Long If m_hWnd = 0 Then Set Parent = Nothing ElseIf apiIsWindow(m_hWnd) Then lngHWnd = apiGetParent(m_hWnd) fwParent.hWnd = lngHWnd Set Parent = fwParent Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If Set fwParent = Nothing End Property ثانيا الموديول ولن يفرق اسم الموديول فى شئ '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 ' Call CenterForm(Me) ' Call CenterReport(Me) Sub CenterForm(F As Form) If F.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = F.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf F.PopUp = True Then Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height formAllMarginsWidth = F.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < F.WindowHeight Then formHeight = F.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End If End Sub Sub CenterReport(R As Report) If R.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = R.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf R.PopUp = True Then Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End If End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم استدعاء كود توسيط النماذج من خلال السطر الاتى فى حدث عند الفتح Call CenterForm(Me) ويتم استدعاء كود توسيط التقارير من خلال السطر الاتى فى حدث عند الفتح Call CenterReport(Me) فى حالة كانت PopUp = True يتم توسيط النماذج والتقارير فى وسط شاشة الحاسب الالى تمام تبعا لابعاد الشاشة اما فى حالة PopUp = False يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه والان اليكم المرفق بالمثال العملى AutoCentre.mdb

بسم الله الرحمن الرحيم كما تعودنا واستكمالا لشروحات الفورم التفاعلي باضافات بعض الحيل والافكار للوصول لشكل يسهل للمستخدم التعامل مع اليوزفورم النهاردة هانتعلم الذاي نعمل قائمة منسدلة لجميع تبويات الفورم من خلال بعض الاعدات في شيت منفصل بعيدا عن تعقيدات الاكواد وتكرارها باستخدام Class Modules كود واحد ومختصر وقائمة واحدة تتغير حسب التبويب كنت وعد احد الاخوة في موضوع الدرس الأول للفورم التفاعلي الاخ اسامة فوزي واحتياجه لفورم متعدد المهام والوظائف ليطور عمله ففضلت ان تكون الاجابة عامة حتى يستفيد منها الجميع وادعوا الله ان اكون عند حسن ظنه وظنكم في. أطروحتنا النهاردة بسيطة وشيقة اشبه بمغامرة انك تعبر عن قدرتك وتعاملك في التصميم والكود كانك رسام يرسم لوحة وبربط بين تفاصيلها لتعبر عن رؤية بصرية محددة في مخيلة من قام بالرسم وحياكة التفاصيل حياكة متناسقة لتصل الي المتلقي بسهولة ويستطيع ان يتعامل معها ويمكنك تغيير المسميات للقوائم المنسدلة او الرئيسية من خلال شيت الاعدادات بكل سهولة وتضيف كما تشاء من تبويات بكل سهولة اسيبكم مع الملف واي شيء يحتاج لشرح او توضيح لا تتردوا في طلبه والله ولي التوفيق Create Dynamic Drop-Down Menu In Excel Userform الملف بالمرفقات مفتوح المصدر Create Dynamic Drop-Down Menu In Excel Userform Officana.xlsm

السلام عليكم ورحمة الله اولا : ضع الكود التالى فى موديول مستقل و خصص له زر Sub NewTopTen() Dim ws As Worksheet, LR As Long Dim Arr(), Tmp(), n As Integer, Rnk As String Dim i As Integer, j As Integer, p As Integer Dim Num As Integer, y As Integer Const Rep As String = "مكرر" Dim WF As WorksheetFunction, C As Range Set ws = Sheets("ورقة البيانات") Set WF = WorksheetFunction LR = ws.Range("C" & Rows.Count).End(3).Row ReDim Preserve Arr(1 To LR, 1 To 1) For Each C In ws.Range("U8:U" & LR) y = WF.CountIf(ws.Range(ws.Cells(8, "U"), _ ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U")) If y = 1 Then p = p + 1 Arr(p, 1) = C.Value End If Next If p < 50 Then n = p - 1 Else n = 50 End If For i = 1 To n Num = WF.Large(Arr, i) For Each C In ws.Range("U8:U" & LR) If C.Value = Num Then Rnk = TextNums(i) C.Offset(0, 1) = Rnk x = WF.CountIf(ws.Range(ws.Cells(8, "U"), _ ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U")) If x > 1 Then Rnk = TextNums(i) & " " & Rep C.Offset(0, 1) = Rnk End If End If Next Next End Sub ثانيا : اما هذه الدالة المخصصة ضعها ايضا فى موديول اخر و لا تتعامل معها مرة اخرى حتى يعمل معك الكود الاول بكفاءة Function TextNums(Num As Integer) As String Dim Ar, Tp, Reslt As String Dim m As Integer Ar = Array("الاول", "الثانى", "الثالث", "الرابع", "الخامس", "السادس", "السابع", _ "الثامن", "التاسع", "العاشر", "الحادى عشر", "الثانى عشر", "الثالث عشر", _ "الرابع عشر", "الخامس عشر", "السادس عشر", "السلبع عشر", "الثامن عشر", _ "التاسع عشر", "العشرين", "الحادى و العشرين", "الثانى و العشرين", _ "الثالث و العشرين", "الرابع و العشرين", "الخامس و العشرين", "السادس و العشرين", _ "السابع و العشرين", "الثامن و العشرين", "التاسع و العشرين", "الثلاثين", "الحادى و الثلاثين", _ "الثانى و الثلاثين", "الثالث و الثلاثين", "الرابع و الثلاثين", "الخامس و الثلاثين", _ "السادس و الثلاثين", "السابع و الثلاثين", "الثامن و الثلاثين", "التاسع ة الثلاثين", _ "الاربعين", "الحادى و الاربعين", "الثانى و الاربعين", "الثالث و الاربعين", "الرابع و الاربعين", _ "الخامس و الاربعين", "السادس و الاربعين", "السابع و الاربعين", "الثامن و الاربعين", _ "التاسع و الاربعين", "الخمسين") Tp = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _ 21, 22, 23, 24, 35, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _ 41, 42, 43, 44, 45, 46, 47, 48, 49, 50) For m = LBound(Ar) To UBound(Ar) If Num = m + 1 Then Reslt = Replace(Num, Num, Ar(m)) End If Next TextNums = Reslt End Function

هي بالفعل ليس لها علاقه بالبرمجه ولكني كنت حابب هذا المجال وبالفعل دراسة الطب وقبلها دراسة العلوم عطلتني كتير فانا مشترك هنا منذ عام ٢٠٠٨ ولله الحمد والمنه وتعلمت الكثير والكثير من مشرفين وأعضاء فهم تاج علي رأسي هذا موضوع يطول شرحه

استخدم دالة Mod للحصول على فرق الشلنات = Mod(Total, 0.05)

اللهم اشفه شفاءا لا يغادر سقما يارب

اخي الطريقة الصحيحة هي اظهار البيانات على الليست بوكس وتحديد الاعمدة المرغوب الفلترة عليها بواسطة الكومبوبكس بطريقة دينامكية (مترابطة ) دون الاعتماد على قوائم اظافية مع وضع تيكست بوكس تقوم بفلترة البيانات بمجرد الكتابة دون الظغط على ازرار . 2) الملف غير منظم مما يشكل صعوبة لفهم المطلوب جيدا ربما كان من الافضل فقط تصميم يوزرفورم وطلب المساعدة بتكملت الاكواد احسن من التعديل على ملف قديم لا يناسب طلبك .

أخي @ابوالعزائم .. الخيار التالي : () يوضع للمشاركة التي تحتوي على الحل الأنسب لمشكلتك التي طرحتها في الموضوع 🙂 للعلم 🙂

وعلكيم السلام ورحمة الله اخي من قضلك قم بتوضيح اكثر... يمكنك كتابة المراد تنفيزة ولو بطريقة يدوية داخل الملف بشرح مبسط وواضح لكي يتفهم المطلوب لدا الجميع مثلاً .... اريد جمع عمود b....او اريد جمع ربح كل فاتورة عميل علي حدة...وهكذا

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

ربنا يشافيه ويعافيه ويعطيكم الصبر على الابتلاء.. لو سمحت يادكتور ..ربنا يعطيك العافية.. يعني لوعندك 100 مريض..هل ستعمل تقارير بعددهم ؟ لي ماتعمل تجميع لفحوصات كل مريض على اختلاف التواريخ وتعرضها في تقرير واحد ..يعني ماتحتاج لكل هاي التقارير

لاترفع كل الملف ..اعمل ملف جديد واستورد الجداول والنماذج والتقارير التي تحتاج تعديل

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

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

السلام عليكم ورحمه الله وبركاته ممكن تراجع هذا الموضوع أدناه ⬇️ قد يفيدك

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

بداية اتفق مع الاستاذ @عبدالجيد في امكانية عمل البرنامج بشكل يتوافق مع تصميم قواعد البيانات مشاركة مع الاستاذ @Moosak طريقة بسيطة باستخدام عد الحقول الفارغة الملف مرفق واعتذر مقدما لعدم مراجعة العمل لانشغالي Database13.accdb

وعليكم السلام ورحمة الله وبركاته أخي @مصطفى العراقي1988 🙂 هل تقصد الصفوف الفارغة تماما من أية بيانات ؟ طبعا ستحتاج لتنفيذ ذلك إلى استعلام حذف .. بحيث تكتب في معيار جميع الخلايا ( Is Null ) أو تضع هذه ="" ثم تشغل الاستعلام .. وشيء آخر أخي مصطفى ، حاول ألا تجعل أسماء الحقول أرقام فقط أو جملة تبدأ بأرقام .. وإنما أعد تسميتها هكذا مثلا : Day1 Day2 Day3 Day4 ...................... وهكذا وذلك تجنبا للمشاكل البرمجية لاحقا .. 🙂

'طيب اولا لست انا من قام بكتابة الكود ثانيا يا سيدى الكود هذا افضل كود تشفير تعاملت معه لعدة اسبب -هذا الكود عند تشفير نفس الكلمة أكثر من مرة فى كل مره تحصل على رموز مختلفة ولكن عند اعادتها من اى رمز حلصلت عليه اثناء التشقير تعود اليك تلك الكلمة -يتم تصدير الكود كما هو مشفر لان هناك بعد الأكود عند تصدير القيم الناتجة عنه الى الريجسترى عادت الى الحروف الأصلية أما بخصوص المتعير b هو معامل التشفير الذى يعتمد الكود عليه يعنى مثلا عاوز اشفر الاسم موسى باستخدام الكواد على سبيل المثال يكون incode("موسي","FrstName") انا استخدمت معامل التشفير هنا كلمة FrstName اذا لابد من استخدامها كما هى لاعادة الكلمة الى اصلها يعنى هذا التشفير كGFـغصظ×ظضضصسرج والذى تم الحصول عليه من كلمة موسي لابد لاعادته الى اصله من استخدام نفس معامل التشفير المستخدم بيكون عند الفك للتشفير decode("كGFـغصظ×ظضضصسرج","FrstName") طيب جرب تغيير حالة حرف مثلا ?decode("كGFـغصظ×ظضضصسرج","Frstname") لاحظ حرف الـ N , n بذلك لن تستطيع اعادة العملية وليش الراحة مطلوب البحث والتحرى لو ع الراحة اقوم بتقفيل قاعدة وارفقها فى شكلها النهائى وارتاح واريح

طبعا أيوه 😂 .. كل حاجة 😁 لا أنا بس سؤالي الحين عن دوال التشفير .. ليش حاط المتغير الثاني الـ b ؟؟؟ أيش فائدته في الكود ؟ ولو كان حطيت شرح أو توضيح بسيط كـ كومنتس في الكود كان ريحت جميع سكان الكرة الأرضية من البحث والتحري 😅 والله يبارك لك هذي العقلية الفذة والشغل العدل 😉👌

Book1.xlsmتفضل أخي الكريم

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

ان شاء الله جارى العمل على تحضير باقى الافكار تباعا ولكن قبل الاستكمال هل هناك ما يحتاج الى شرح أو توضيح فيما سبق ؟!

في زر الامر ضع الكود التالي ⬇️ Dim rs As DAO.Recordset Dim i As Integer Dim r As String Set rs = CurrentDb.OpenRecordset("test") rs.MoveFirst For i = 1 To rs.RecordCount If rs!ID = Me.ID Then r = rs!Rptname DoCmd.OpenReport r, acViewPreview End If rs.MoveNext Next rs.Close Set rs = Nothing ربما توجد طرق ابسط ولكن ليس لدي وقت لذلك اللهم اشف والدي واجعل ما اصابه من ابتلاء في ميزان اعماله Multi Report.accdb

السلام عليكم ورحمة الله تعالى وبركاته ملاحظة :بعد ادن الاخوة الكرام بعد معاينة الكود الموجود في اليوزرفورم السائل ربما يقصد انشاء اوراق عمل جديدة طبق الاصل للورقة المخفية (sample) بشرط الاسماء الموجودة في عمود H شيت ( Vehicle ) واعادة تسميتها بنفس القيمة

آمل ان يكون هذا هو مطلوبك Public Function OrderAwael(Roundx As Double) As String Set rs = CurrentDb.OpenRecordset("SELECT COUNT(*) + 1 FROM (SELECT qryRank.Rounded FROM qryRank GROUP BY qryRank.Rounded) As temp WHERE temp.Rounded > " & Roundx, dbOpenSnapshot) OrderAwael = rs(0) rs.Close End Function Ranks.accdb

عليكم السلام أخي العزيز أذا كنت تقصد Sub Replace() فهذا الكود يحذب كل شيئ ما عدا (ع -ايفاد -1) من المثال في ملفك المرفق Sub Replace() Dim sheet As Worksheet Dim Réf As Variant Dim y As Long Réf = Array("X", "X3", "X5", "س11", "س13", "س8", "جمعة", "سبت", "ط8", "3", "8", "5", "س") For Each sheet In ActiveWorkbook.Worksheets For y = LBound(Réf) To UBound(Réf) sheet.Cells.Replace What:=Réf(y), Replacement:="" Next Next End Sub

السلام عليكم و رحمة الله ترتيب الطلاب من الاول حتى العاشر على اساس الدرجات فى العمود T Sub ReRank() Dim ws As Worksheet, Arr() Dim LR As Long, y As Integer, TP() Dim j As Long, p As Long, m As Long, Trb As String Dim i As Long, x As Double, k As Double Set ws = Sheets("ورقة البيانات") LR = ws.Range("C" & Rows.Count).End(3).Row Range("U8:U" & LR).Value = "" ReDim Arr(1 To LR, 1 To 1) j = 8 Do While j <= LR y = WorksheetFunction.CountIf(ws.Range(ws.Cells(8, "T"), _ ws.Cells(j, "T")), ws.Cells(j, "T")) If y = 1 Then i = i + 1 Arr(i, 1) = ws.Cells(j, "T") End If j = j + 1 Loop x = WorksheetFunction.Large(Arr, 10) ReDim TP(1 To i, 1 To 1) For r = 1 To i If Arr(r, 1) >= x Then p = p + 1 TP(p, 1) = Arr(r, 1) End If Next m = 8 Do While m <= LR For n = 1 To 10 k = WorksheetFunction.Large(TP, n) If ws.Cells(m, "T") = k Then Trb = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _ "السادس", "السابع", "الثامن", "التاسع", "العاشر") If WorksheetFunction.CountIf(ws.Range("T8:T" & m), _ ws.Range("T" & m)) > 1 Then Trb = Trb & " " & "مكرر" ws.Cells(m, "U") = Trb Else Trb = Trb ws.Cells(m, "U") = Trb End If End If Next m = m + 1 Loop End Sub

ان شاء الله يكون جيدا

السلام عليكم ورحمة الله تعالى وبركاته. تفضل اخي ربما تقصد ترحيل البيانات بشرط الإسم الموجود في الخلية M3 اليك حل آخر بالمعادلات . INDIRET COSTS 2023_V1.xlsx

Private Sub CommandButton4_Click() Dim i As Long Dim WS As Worksheet Set WS = Worksheets("مخزن (2024)") With WS r = .Columns(2).Cells.Find(Me.TextBox2, , , 1).Row For i = 2 To 12 .Cells(r, i) = UserForm1.Controls("Textbox" & i).Value UserForm1.Controls("Textbox" & i).Value = "" Next End With End Sub

تفضل Private Sub CommandButton6_Click() Select Case ComboBox1.Value Case "بحث في الاسماء" ListBox1.Clear For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i If TextBox1 = "" Then Exit Sub Sheets("Sheet1").Activate ss = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row j = 0 For Each C In Range("a2:a" & ss) If C Like TextBox1.Value & "*" Then ListBox1.AddItem ListBox1.List(j, 0) = Cells(C.Row, 1).Value ListBox1.List(j, 1) = Cells(C.Row, 2).Value ListBox1.List(j, 2) = Cells(C.Row, 3).Value j = j + 1 End If Next C Case "بحث في الرقم القومي" ListBox1.Clear For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i If TextBox1 = "" Then Exit Sub Sheets("Sheet1").Activate ss = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row j = 0 For Each C In Range("c2:c" & ss) If C Like TextBox1.Value & "*" Then ListBox1.AddItem ListBox1.List(j, 0) = Cells(C.Row, 1).Value ListBox1.List(j, 1) = Cells(C.Row, 3).Value j = j + 1 End If Next C Case "بحث في تاريخ الميلاد" ListBox1.Clear For i = 1 To 12 Controls("textbox" & i + 1).Value = "" On Error Resume Next Next i If TextBox1 = "" Then Exit Sub Sheets("Sheet1").Activate ss = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row j = 0 For Each C In Range("b2:b" & ss) If C Like TextBox1.Value & "*" Then ListBox1.AddItem ListBox1.List(j, 0) = Cells(C.Row, 1).Value ListBox1.List(j, 1) = Cells(C.Row, 2).Value j = j + 1 End If Next C End Select End Sub 1- 2- 3- project.xlsm

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته بناء على رسالة من أخي الفاضل / محمد طاهر واعتماد طريقة جديدة وبسيطة في التفكير بصورة عملية ربما يفيدكم هذا الملف بإذن الله وفقنا الله وإياكم لكل ما يحب ويرضى حذف الصفوف والأ‘عمدة بالكود.rar

طبعا لا