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

ضع الكود التالي في حدث ورقة DATA لجلب اسماء العملاء Private Sub Worksheet_Change(ByVal Target As Range) Set F = Sheets("DATA"): Set n = F.[G2] With Application .ScreenUpdating = False .EnableEvents = False If Target.Column = 1 Then F.Range("G2:G" & F.UsedRange.Rows.Count).ClearContents Set d = CreateObject("Scripting.Dictionary") a = Range(F.[A2], F.[A65000].End(xlUp)).Value For Each c In a d(c) = "" Next c n.Resize(d.Count, 1) = Application.Transpose(d.keys) n.Resize(d.Count, 1).Sort Key1:=n, Order1:=xlAscending Set d = Nothing End If .EnableEvents = True .ScreenUpdating = True End With End Sub مع تسمية النطاق وليكن مثلا list واخيرا قم بنسخ هدا في حدث ورقة 7 Option Compare Text Dim F(), OneRng, lr& Public Property Get Sh2() As Worksheet: Set Sh2 = Worksheets("DATA") End Property Private Sub ComboBox1_Change() Dim Cnt() Set OneRng = ActiveCell: Cnt = Application.Transpose([List]) Me.ComboBox1.List = Cnt If Me.ComboBox1.ListIndex = -1 And _ IsError(Application.Match(Me.ComboBox1, Cnt, 0)) Then Me.ComboBox1.List = Filter(Cnt, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If OneRng.Value = Me.ComboBox1 End Sub '************************* Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim sh1 As Worksheet: Set sh1 = Worksheets("7") lr = 150 'sh1.Range("a" & sh1.Rows.Count).End(xlUp).Row Set tmp = Range("C4:C" & lr) If Not Intersect(tmp, Target) Is Nothing And Target.Count = 1 Then If Cnt <> "" Then If IsError(Application.Match(Range(Cnt), F, 0)) Then Range(Cnt) = "" F = Application.Transpose(Sh2.Range("list")) Me.ComboBox1.Height = Target.Height + 4 Me.ComboBox1.Width = Target.Width Me.ComboBox1.BackColor = RGB(204, 253, 253) Me.ComboBox1.Top = Target.Top: Me.ComboBox1.Left = Target.Left: Me.ComboBox1 = Target Me.ComboBox1.Visible = True Me.ComboBox1.Activate Cnt = Target.Address Else Me.ComboBox1.Visible = False End If End Sub '************************* Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Set OneRng = ActiveCell If KeyCode = 13 Then If IsError(Application.Match(OneRng, F, 0)) Then OneRng = "" OneRng.Offset(1).Select End If End Sub '************************* Private Sub ComboBox1_DropButtonClick() lr = Sh2.Cells(Rows.Count, 7).End(xlUp).Row ComboBox1.List = Sh2.Range("G2:G" & lr).Value End Sub '************************* Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then ComboBox1.Value = "" End If End Sub البحث باي جزء من الاسم يمكنك استخدام نفس الكود على اي ورقة بعد تعديل الاسم Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim sh1 As Worksheet: Set sh1 = Worksheets("7") <====== قائمة بحث بجزء من الاسم.xlsb

شرف ليا انى اضيف موضوع وسط اساتذتى https://www.mediafire.com/file/pzr38qxqwg4e2a2/Ferry_Login_v1-_free.accdb/file Ferry Login v1free.accdb

@فريدالطحانشكرا على المرفق تعديل مرفق😇 1- اضافة اكشن عند الفتح 2- عدم تمكين اضافة احرف العربية عند ادخال كلمة المرور او السر مع التجديد Ferry Login v1free.rar

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

تعديل مرفق استاذ @Foksh 😇 1- ان شاء كود لكافة عناصر الفورم فقط اختيار النموذج 2- يفتح حدث الفورم فقط لصق ctrl +V ملاحظة فقط اضافة حدث عند الفتح حتى لو كان فارغ admin.rar

كنت مسافره وانشغلة 😇 تحديث خفيف وتنشيط 1- اضافات بسيطة تحكم بالتيوب 2- تحكم بكافة الفورم بمفاتيح الكيبورد 3- وابسط تحكم بإظهار واخفاء اطار الاكسس اذا كان اختفاء كلي تظهر رسائل اخطاء وعدم استجابة في بعض الاكواد بعدها تحديث الطقس شمالي غربي الرياح نشطة 😂 SQL2VBA (Control_key).rar

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

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

الاول حمد الله على سلامتك استاذ/ فايد هل النموذج الفارغ هذا اعمله داخل قاعدة النماذج (القاعدة الامامية) سوف اجرب الان واجعله داخل داخل قاعدة النماذج جزاك الله خيرا

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

حمدا لله على سلامتك اخي فادي بعض التصور يدور في مخيلتي : - بما ان الواجهات في الأصل تفتح على شاشة البداية لماذا ندرج هذا السطر او الامر اعلاه لفتح نموذج محدد ؟

حتى أعمالك السابقة 😉👌

Sub RemoveChars() Dim lr&, Cel As Range, A As String, r As Range lr = Cells(Rows.Count, "b").End(xlUp).Row Application.ScreenUpdating = False Set r = Range("b2:b" & lr) For Each Cel In r A = Replace(Cel.Value, ",", " ") Cel.Value = A Next Cel Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته تفضل =SUBSTITUTE(B2;",";" ")

ان شاءالله هشوفها بكرة وابلغك... لكن سواء دا طلبي او لاء استاذنا foksh يكفي انك رديت وتساعدني وتساعد الكل. ربنا يجعله في ميزان حسناتك وحسناتكم ويزيدكم علم. وشكرا مرة تانية

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

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

هل هذا طلبك أخي الكريم @Zooro1 ؟؟ admin.accdb

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

أنصحكم بإضافة هداياكم القيمة لمكتبة الموقع : 🙂 https://www.officena.net/ib/files/category/5-قسم-الأكسيس/

واااااالعه يا بروف 😉 😉

اشكرك على الهدية تسلم ايدك تصميم جميل

تفضل استاذ @2saad طلبك في (Report1) وانا حاضر لأي طلب أو تعديل . DDTest6003-1.rar

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

يفضل إرفاق ملفك أو جزء منه مع توضيح المطلوب بالتفصيل وستجد ما يسرك إن شاء الله

بارك الله فيكم جميعا لتغيير نص أزرار رسالة msgbox يمكن استعمال هذا الموديول يوجد مثالين للاستخدام #If VBA7 Then Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" _ () As Long 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 SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" _ (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long Private Declare PtrSafe Function CallNextHookEx Lib "user32" _ (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As LongPtr) As Long Private hHook As LongPtr ' handle to the Hook procedure (global variable) #Else Private Declare Function GetCurrentThreadId Lib "kernel32" _ () 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 SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long Private Declare Function CallNextHookEx Lib "user32" _ (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private hHook As Long ' handle to the Hook procedure (global variable) #End If Private Const WH_CBT = 5 ' hook type Private Const HCBT_ACTIVATE = 5 ' activate window Private sMsgBoxDefaultLabel(1 To 7) As String Private sMsgBoxCustomLabel(1 To 7) As String Private bMsgBoxCustomInit As Boolean Private Sub MsgBoxCustom_Init() Dim nID As Integer Dim vA As Variant ' base 0 array populated by Array function (must be Variant) vA = VBA.Array(vbNullString, "OK", "Cancel", "Abort", "Retry", "Ignore", "Yes", "No") For nID = 1 To 7 sMsgBoxDefaultLabel(nID) = vA(nID) sMsgBoxCustomLabel(nID) = sMsgBoxDefaultLabel(nID) Next nID bMsgBoxCustomInit = True End Sub Public Sub MsgBoxCustom_Set(ByVal nID As Integer, Optional ByVal vLabel As Variant) If nID = 0 Then Call MsgBoxCustom_Init If nID < 1 Or nID > 7 Then Exit Sub If Not bMsgBoxCustomInit Then Call MsgBoxCustom_Init If IsMissing(vLabel) Then sMsgBoxCustomLabel(nID) = sMsgBoxDefaultLabel(nID) Else sMsgBoxCustomLabel(nID) = CStr(vLabel) End If End Sub Public Sub MsgBoxCustom_Reset(ByVal nID As Integer) Call MsgBoxCustom_Set(nID) End Sub #If VBA7 Then Private Function MsgBoxCustom_Proc(ByVal lMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr #Else Private Function MsgBoxCustom_Proc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long #End If Dim nID As Integer If lMsg = HCBT_ACTIVATE And bMsgBoxCustomInit Then For nID = 1 To 7 SetDlgItemText wParam, nID, sMsgBoxCustomLabel(nID) Next nID End If MsgBoxCustom_Proc = CallNextHookEx(hHook, lMsg, wParam, lParam) End Function Public Sub MsgBoxCustom( _ ByRef vID As Variant, _ ByVal sPrompt As String, _ Optional ByVal vButtons As Variant = 0, _ Optional ByVal vTitle As Variant, _ Optional ByVal vHelpfile As Variant, _ Optional ByVal vContext As Variant = 0) hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxCustom_Proc, 0, GetCurrentThreadId) If IsMissing(vHelpfile) And IsMissing(vTitle) Then vID = MsgBox(sPrompt, vButtons) ElseIf IsMissing(vHelpfile) Then vID = MsgBox(sPrompt, vButtons, vTitle) ElseIf IsMissing(vTitle) Then vID = MsgBox(sPrompt, vButtons, , vHelpfile, vContext) Else vID = MsgBox(sPrompt, vButtons, vTitle, vHelpfile, vContext) End If If hHook <> 0 Then UnhookWindowsHookEx hHook End Sub Sub Custom_MsgBox_1() MsgBoxCustom_Set vbOK, "Open" MsgBoxCustom_Set vbCancel, "Close" MsgBoxCustom ans, "Click a button.", vbOKCancel End Sub Sub Custom_MsgBox_2() MsgBoxCustom_Set vbYes, "Start" MsgBoxCustom_Set vbNo, "Stop" MsgBoxCustom ans, "Click a button.", (vbYesNo + vbQuestion) End Sub بالتوفيق للجميع

20 / 365.2425 * 354.367 240 / 365.2425 * 354.367

الكود بطريقة اخرى مع الشرح لتتمكن من تعديله بما يناسبك Public Sub CopyData2() Dim rCrit() As String: ReDim rCrit(1 To 2): Const SrcRow = "EA" Dim x&, i&, Cnt&, arr&, lr&, lastRow&, Cpt As Long Dim Search_Row As Long, Star_Row As Long, Col As Range Dim rngA As Variant, rngB As Variant, OneRng As Range Dim WS As Worksheet: Set WS = Sheets("cheet4") Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ") ' تحديد صف البداية Star_Row = 16: ' عمود الفلترة Search_Row = 131 'تحديد صف وضع البيانات المرحلة Cnt = 10 With Application .ScreenUpdating = False .Calculation = xlManual lastRow = WS.Range(SrcRow & WS.Rows.Count).End(xlUp).Row lr = srcWS.Columns("C:AP").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'معايير الفلترة rCrit(1) = "غ": rCrit(2) = "*" & "دور ثان" & "*" 'الاعمدة المرحلة rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row) 'الاعمدة المرحل اليها rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 15, 18, 21, 24, 27, 30, 33, 36, 39, 42) '("EA")'التحقق من وجود المعايير على عمود arr = Application.Sum _ (Application.IfError(Application.Match(rCrit, WS.Columns(Search_Row), 0), 0)) If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _ vbCritical, "انتباه": Exit Sub 'افراغ البيانات السابقة For x = 0 To UBound(rngB) Set Col = srcWS.Range(srcWS.Cells(Cnt, rngB(x)), srcWS.Cells(lr, rngB(x))) Col.ClearContents Next x With WS If .AutoFilterMode Then .AutoFilterMode = False ' تحديد نطاق البيانات With WS.Range("C15:EA15") .AutoFilter Search_Row - 2, rCrit, xlFilterValues ' نسخ الاعمدة المرئية For i = 0 To UBound(rngA) Set OneRng = WS.Range(WS.Cells(Star_Row, _ rngA(i)), WS.Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy 'لصق البيانات srcWS.Cells(Cnt, rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Next i .AutoFilter End With End With .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub SAAD V3.xlsm

والشئ بالشئ يذكر يا استاذ @Foksh انظر الى هذه المضوع لانه مهم جدا جدا ان اردت تقديم اى قاعدة بيانات مشفرة فيما بعد