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

Try this code. Copy the headers manually first. The code will put the results at row 7 as start point Sub Test() Const SROW As Long = 7 Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With sh.Rows(SROW & ":" & Rows.Count).Cells.Clear lr = ws.Cells(Rows.Count, "C").End(xlUp).Row If lr < SROW Then Exit Sub ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW) ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW) For r = SROW To lr If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r)) End If Next r If Not rng Is Nothing Then rng.EntireRow.Delete lr = sh.Cells(Rows.Count, "C").End(xlUp).Row If lr < SROW Then Exit Sub sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")") Application.ScreenUpdating = True End Sub

In ThisWorkbook Module Private Sub Workbook_Open() Application.OnKey "{F9}", "TestMacro" End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F9}" End Sub In Standard Module Sub TestMacro() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Qution") ws.Range("G17").Value = Empty: ws.Range("D17").Value = Empty With ws.Range("D17") .Formula = "=RANDBETWEEN(data1!A1,data1!A30)" .Value = .Value End With With Application .ScreenUpdating = True .EnableEvents = False .Calculation = xlCalculationManual .Wait Now + TimeValue("00:00:05") ws.Range("G17").Formula = "=LOOKUP(D17,data1!A1:A730,data1!F1:F30)" .Calculate .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub

تفضل أخي العزيز .. ولزيادة الخير وضعت لك أكواد جميع الإجراءات الأساسية : الإجراءات الإعتيادية للسجلات ( حفظ - جديد - حذف - إضافة - تكرار - التالي - السابق - الأول - الأخير - .....) '===================================== حفظ السجل والذهاب لسجل جديد Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord DoCmd.GoToRecord , , acNewRec Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== حذف السجل Private Sub DeleteBtn_Click() On Error GoTo Err_DeleteBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdDeleteRecord Exit_DeleteBtn_Click: Exit Sub Err_DeleteBtn_Click: MsgBox Err.Description Resume Exit_DeleteBtn_Click End Sub '===================================== إضافة سجل جديد Private Sub AddNewBtn_Click() On Error GoTo Err_AddNewBtn_Click DoCmd.GoToRecord , , acNewRec Exit_AddNewBtn_Click: Exit Sub Err_AddNewBtn_Click: MsgBox Err.Description Resume Exit_AddNewBtn_Click End Sub '===================================== السجل التالي Private Sub NextBtn_Click() On Error GoTo Err_NextBtn_Click DoCmd.GoToRecord , , acNext Exit_NextBtn_Click: Exit Sub Err_NextBtn_Click: MsgBox Err.Description Resume Exit_NextBtn_Click End Sub '===================================== السجل السابق Private Sub PreviousBtn_Click() On Error GoTo Err_PreviousBtn_Click DoCmd.GoToRecord , , acPrevious Exit_PreviousBtn_Click: Exit Sub Err_PreviousBtn_Click: MsgBox Err.Description Resume Exit_PreviousBtn_Click End Sub '===================================== السجل الأول Private Sub FirstBtn_Click() On Error GoTo Err_FirstBtn_Click DoCmd.GoToRecord , , acFirst Exit_FirstBtn_Click: Exit Sub Err_FirstBtn_Click: MsgBox Err.Description Resume Exit_FirstBtn_Click End Sub '===================================== السجل الأخير Private Sub LastBtn_Click() On Error GoTo Err_LastBtn_Click DoCmd.GoToRecord , , acLast Exit_LastBtn_Click: Exit Sub Err_LastBtn_Click: MsgBox Err.Description Resume Exit_LastBtn_Click End Sub '===================================== البحث عن سجل Private Sub FinedRecBtn_Click() On Error GoTo Err_FinedRecBtn_Click Screen.PreviousControl.SetFocus DoCmd.RunCommand acCmdFind Exit_FinedRecBtn_Click: Exit Sub Err_FinedRecBtn_Click: MsgBox Err.Description Resume Exit_FinedRecBtn_Click End Sub '===================================== تكرار السجل Private Sub DublicateRecBtn_Click() On Error GoTo Err_DublicateRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Exit_DublicateRecBtn_Click: Exit Sub Err_DublicateRecBtn_Click: MsgBox Err.Description Resume Exit_DublicateRecBtn_Click End Sub '===================================== حفظ السجل Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== طباعة السجل الحالي Private Sub PrintRecBtn_Click() On Error GoTo Err_PrintRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.PrintOut acSelection Exit_PrintRecBtn_Click: Exit Sub Err_PrintRecBtn_Click: MsgBox Err.Description Resume Exit_PrintRecBtn_Click End Sub '===================================== التراجع عن التسجيل Private Sub UndoRecBtn_Click() On Error GoTo Err_UndoRecBtn_Click DoCmd.RunCommand acCmdUndo Exit_UndoRecBtn_Click: Exit Sub Err_UndoRecBtn_Click: MsgBox Err.Description Resume Exit_UndoRecBtn_Click End Sub '===================================== فتح التقرير وطباعة السجل المحدد بدلالة الرقم التسلسلي Private Sub Print_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport, , "ID =" & Me.ID DoCmd.RunCommand acCmdPrintPreview DoCmd.RunCommand acCmdPrint Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: If Err.Number = 2501 Then Resume Exit_OpenReportBtn_Click 'print cancelled MsgBox Err.Number & vbCr & Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== طباعة تقرير Private Sub PrintReportBtn_Click() On Error GoTo Err_PrintReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acNormal Exit_PrintReportBtn_Click: Exit Sub Err_PrintReportBtn_Click: MsgBox Err.Description Resume Exit_PrintReportBtn_Click End Sub '===================================== معاينة تقرير Private Sub VeiwReportBtn_Click() On Error GoTo Err_VeiwReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acPreview Exit_VeiwReportBtn_Click: Exit Sub Err_VeiwReportBtn_Click: MsgBox Err.Description Resume Exit_VeiwReportBtn_Click End Sub '===================================== فتح تقرير Private Sub OpenReportBtn_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: MsgBox Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== حفظ تقرير بصيغة Private Sub SendReportToBtn_Click() On Error GoTo Err_SendReportToBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OutputTo acReport, stDocName Exit_SendReportToBtn_Click: Exit Sub Err_SendReportToBtn_Click: MsgBox Err.Description Resume Exit_SendReportToBtn_Click End Sub

وهنا بالمعادلات خالد.xlsb

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

When you copy the code from the VBE to notepad, make sure the direction is for Arabic language, then copy the code to the notepad and you will find everything is OK

السلام عليكم ورحمه الله

وعليكم السلام محاولة بنفس التفكير مع العلم بوجود دالة جاهزة بالأكسل لتوزيع الأقساط 1تقسم قيمه الدين.xlsx

السلام عليكم ورحمة الله حسب فهمي للمطلوب، جرب الملف المرفق... تقسم قيمه الدين.xlsx

لتجربة الأصناف اختر من الأرقام 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1020 1400 1110 1000 الكاشير.xlsm

هذا ملف ادعو الله ان يجزي بالخير كل من ساعد علي ظهوره برنامج بسيط لشئون العاملين رقم الدخول 1111 شئون+العاملين+2016.rar

قام الاستاذ القدير @ابوخليل بترشيح العضو @دروب مبرمج للترقية إلى خبير مبارك عليك أيها الزميل الترقية.. أنت تستحقها بجدارة

السلام عليكم و رحمة الله و بركاته ارجو المساعدة بماكرو يجبر الفورم باظهار الارقام الموجودة في التكس بوك جميعها 1و2و3و4 الى الارقام العربية دون الحاجة الى الذهاب الى كنترول بانل و اللغات مرفق صورة الى الارقام الانجلزية بحاجة الى تحول الى ارقام الهندية و شكرا mark.xlsm

السلام عليكم ورحمة الله وبركاته ... فيه سؤال للأخ الرهوي في الرابط التالي يسأل عن البحث داخل مربع التحرير والسرد نفسه بمجرد الكتابة http://www.officena.net/ib/topic/66565-كيف-ابحث-في-مربع-سرد-بجزء-من-الكلمة-؟/ بحثت وحاولت ولم افلح ... وبعد بحث طويل وجدت المطلوب .. في الحقيقة لا اعلم ان كان هناك طرق اخرى ... ولكن بالنسبة لي لم اجد الا هذه الطريقة القوا نظرة على المرفق ان شاء الله يفيدكم .. هذا رابط المرجع ... http://www.tek-tips.com/faqs.cfm?fid=6295 وهذا الكود الأساسي مع الشرح قبل التعديل Private Sub Combo0_Change() ' Function Description: ' Filter a combo box list as the user types, similarly to how application ' launchers like Colibri, AppRocket and LaunchBar opperate. ' e.g. if the list contains the names of U.S. Presidents, and ' the user types "gw," then the resulting SQL WHERE clause will ' look like "Name Like '*g*w*'" and the resulting list ' will include George Washington, George H. W. Bush and ' George W. Bush, among others. ' The order is preserved, so that typing "wg" creates an SQL WHERE ' clause like "Name Like '*w*g*'" and the resulting list would ' include George Washington but not the Bushes. ' This is accomplished by grabbing the text typed by the user in the ' combo box's edit field, creating an SQL SELECT statement from it, ' and finally applying that SQL statement to the combo box's ' .RowSource property. ' Form design settings: ' Set AutoExpand to No ' Column Count 3 ' Keyed on column 1 (record primary key) ' Showing column 2 (user-readable data) column 2 width > 0 ' First and Second column width=0 Dim strText, strFind ' Get the text that the user has typed into the combo box editable field. strText = Me.Combo0.Text ' If the user has typed something in, then filter the combobox ' list to limit the visible records to those that contain the ' typed letters. ' Otherwise (if the field is blank), the user has deleted whatever ' text they typed, so show the entire (unfiltered) list If Len(Trim(strText)) > 0 Then ' Show the list with only those items containing the typed ' letters. ' Create an SQL query string for the WHERE clause of the SQL ' SELECT statement. strFind = "Name Like '" For i = 1 To Len(Trim(strText)) If (Right(strFind, 1) = "*") Then ' When adding another character, remove the ' previous "*," otherwise you end up with ' "*g**w*" instead of "*g*w*." ' This has no apparent impact on the user, but ' ensures that the SQL looks as intended. strFind = Left(strFind, Len(strFind) - 1) End If strFind = strFind & "*" & Mid(strText, i, 1) & "*" Next strFind = strFind & "'" ' Create the full SQL SELECt string for the combo box's ' .RowSource property. strSQL = "SELECT tName.nameKey, tName.Name, SortOrder FROM tName Where " & _ strFind & " ORDER BY SortOrder;" '' NOTE: to remove the order requirement, such that typing "wg" '' and "gw" return the same results, the SQL WHERE clause needs '' to look like "Name Like '*w* AND *g*'." '' The code above should be changed as follows: ''For i = 1 To Len(Trim(strText)) '' strFind = strFind & "Name Like '*" & Mid(strText, i, 1) & "*' And " ''Next '' ''strSQL = "SELECT tName.nameKey, tName.Name, SortOrder from tblApps Where " & _ ''Left(strFind, Len(strFind) - 5) & " Order By SortOrder" ' Filter the combo list records using the new SQL statement. Me.Combo0.RowSource = strSQL Else ' Show the entire list. strSQL = "SELECT tName.nameKey, tName.Name, tName.SortOrder FROM tName ORDER BY tName.SortOrder; " Me.Combo0.RowSource = strSQL End If ' Make sure the combobox is open so the user ' can see the items available on list. Me.Combo0.Dropdown End Sub اتمنى من خبرائنا واعضاء المنتدى الكرام القاء نظرة على المرفق وعلى الكود كامل لو فيه اضافات او تعديلات . وبالتوفيق للجميع . Search_inside_Combo.rar

Sub Uniques() Dim Rng As Range, derlig& Dim WSDest As Worksheet: Set WSDest = Sheets("Sheet1") derlig = WSDest.Range("a" & Rows.Count).End(xlUp).Row + 1 WSDest.Range("c2:c" & derlig).ClearContents For Each Rng In Range("A2:A" & derlig) If WorksheetFunction.CountIf(Range("B2:B" & derlig), Rng) = 0 Then Range("C" & Rows.Count).End(xlUp).Offset(1) = Rng End If Next End Sub TEST_Uniques.xlsm

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 '====================================================== '====================================================== ' تنسيق التاريخ Private Const DtF As String = "yyyy/mm/dd" '====================================================== ' عُرض تاكست الادخال Private Const iWgt1 As Single = 240 '====================================================== Private Const Frmtop As Single = 3 Private Const Frmlft As Single = 3 Private Const iHgt As Single = 35 Private Const iTop As Single = iHgt + 2 Private Const mBox As Long = vbMsgBoxRight + vbMsgBoxRtlReading '====================================================== Private Ar() As Integer Private MyRngSeri As Range Private MyRngdate As Range Private ContRow As Long Private iRow As Long Private LastColumn As Integer Private tSr As Boolean Private MyList As String Private tAc As Boolean Private iColor1 As Variant Private iColor2 As Variant Private Sub BoxFind_Click() Dim tm As Integer Me.ListFind.Clear tm = Me.BoxFind.Tag Me.Controls("Labeldt" & tm).ForeColor = vbBlack tm = Me.BoxFind.ListIndex + 1 Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor Me.BoxFind.Tag = tm End Sub Private Sub ButtonClear_Click() kh_ClearRecord End Sub Private Sub ButtonEnd_Click() Me.ScrollBar1.Value = ContRow End Sub Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False) Dim tm As Integer '''''''''''''''''''''''''''''''' For tm = 2 To LastColumn If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then Me.Controls("Textdt" & tm) = "" End If Next End Sub Private Sub kh_AddNewRecord() Dim C As Integer '''''''''''''''''' Me.Frame1.ScrollTop = 0 kh_ClearRecord True '''''''''''''''''' Me.LabelSerial = ContRow + 1 Me.LabelSerial2 = ContRow + 1 & " - " & ContRow + 1 kh_Enabled False '''''''''''''''''' With Me.Controls("Textdt1") If .Enabled Then .SetFocus .Text = "يجب الادخال في هذه الخلية افتراضياً" .SelStart = 0 .SelLength = .TextLength Else .Text = "........" End If End With End Sub Private Sub ButtonGo_Click() With MyRngdate .Worksheet.Activate .Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select End With Unload Me End Sub Private Sub ButtonNew_Click() kh_AddNewRecord End Sub Private Sub ButtonNewCancel_Click() ScrollBar1_Change End Sub Private Sub ButtonNewSave_Click() If kh_TestBlank() Then Exit Sub Dim cRow As Long: cRow = ContRow + 1 Me.ScrollBar1.Max = cRow kh_SaveDate cRow, True Me.ScrollBar1.Value = cRow Call MsgBox(" تم حفظ السجل الجديد بنجاح ", mBox, "الحمدلله") End Sub Private Sub ButtonPrint_Click() If Me.Frame1.ScrollHeight > Me.Frame1.Height Then Print1 Else If MsgBox(" هل تريد طباعة السجل على الفورم ؟ ", vbYesNo + mBox, "طباعة على الفورم ") = vbYes Then Print2 Else Print1 End If End If End Sub Private Sub Print1() Dim ctl As Control Dim i As Integer, t As Boolean Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "B").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "C").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("B1").Resize(LastColumn, 2) .ColumnWidth = IIf(t, 28, 37) .Borders.LineStyle = 2 .WrapText = True .VerticalAlignment = xlTop End With Range("A1").ColumnWidth = IIf(t, 17, 0) If t Then AddPrintPicture Range("A1").Resize(LastColumn, 3).PrintPreview .Close False End With '------------------------ Me.Show End Sub Private Sub Print2() Print_Visible False '''''''''''''''''''''''''' If MsgBox(" هل تريد طباعة الفورم حسب هذه المعاينة ؟ ", vbYesNo + mBox, "معاينة قبل الطباعة") = vbYes Then On Error Resume Next Me.PrintForm On Error GoTo 0 End If '''''''''''''''''''''''''' Print_Visible True kh_Enabled True End Sub Private Sub Print_Visible(v As Boolean) Dim ctl As Control '''''''''''''''''''''''''' If v Then Me.BackColor = iColor1 With Me.Frame1 .BackColor = iColor2 .SpecialEffect = 3 End With Else Me.BackColor = vbWhite With Me.Frame1 .BackColor = vbWhite .SpecialEffect = 0 End With End If End Sub Private Sub ButtonSaveDate_Click() If kh_TestBlank() Then Exit Sub kh_SaveDate iRow ScrollBar1_Change Call MsgBox(" تم حفظ التغييرات بنجاح ", mBox, "الحمدلله") End Sub Private Function kh_TestBlank() As Boolean If Len(Trim(Me.Controls("Textdt1"))) = 0 Then kh_TestBlank = True Me.Controls("Textdt1").SetFocus Call MsgBox("العمود : " & Me.Controls("Labeldt1") & vbCr & vbCr & "يجب الادخال في هذه الخلية افتراضياً", mBox + vbCritical, "استخدام خاطىء") End If End Function Private Sub kh_AutoFill() Dim CelFill As Range, CFil As Range Dim R As Integer '''''''''''''''''''''''''' If tSr Then Set CelFill = Union(MyRngSeri, MyRngdate) Else Set CelFill = MyRngdate End If '''''''''''''''''''''''''' For R = 1 To CelFill.Areas.Count Set CFil = CelFill.Areas(R).Rows(ContRow + 1) With CFil .AutoFill .Resize(2), xlFillDefault End With Next Set CelFill = Nothing Set CFil = Nothing End Sub Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False) Dim MyVelue, Msg Dim C As Integer, cc As Integer '''''''''''''''''''''''''' 'On Error GoTo 1 '''''''''''''''''''''''''' Application.Calculation = xlCalculationManual '''''''''''''''''''''''''' If nR > 1 And tFil Then kh_AutoFill If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR ''''''''''''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) If Me.Controls("Textdt" & cc).Enabled = True Then With MyRngdate MyVelue = Me.Controls("Textdt" & cc).Text If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Else If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then Msg = MsgBox("الخلية في العمود : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _ & "منسقة كتاريخ والادخال الجديد رقم" & vbCr & vbCr _ & "هل تريد مسح تنسيقات الارقام السابقة ؟؟", mBox + vbYesNo, "تأكيد مسح تنسيقات التاريخ السابقة ؟؟ ") ''''''''''''''''''''''''' If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = "" End If End If .Cells(nR + 1, C).Value = MyVelue End With End If Next '''''''''''''''''''''''''' 1: Application.Calculation = xlCalculationAutomatic '''''''''''''''''''''''''' End Sub Private Sub ButtonExit_Click() Unload Me End Sub Private Sub ButtonDelete_Click() If MsgBox(" هل تريد حذف السجل رقم : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "تاكيد الحذف ") = vbNo Then Exit Sub If Me.ListFind.ListCount Then Me.ListFind.Clear MyRngdate.Rows(iRow + 1).EntireRow.Delete If Not tSr Then GoTo 1 If iRow = ContRow Then GoTo 1 With MyRngSeri .Cells(iRow + 1, 1).Value = iRow Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries End With 1: Me.ScrollBar1.Max = ContRow - 1 ScrollBar1_Change Call MsgBox(" تم حذف السجل بنجاح ", mBox, "الحمدلله") End Sub Private Sub ButtonTop_Click() If ContRow Then Me.ScrollBar1.Value = 1 End Sub Private Sub CheckFind_Click() Me.ListFind.Clear Me.LblFindCount = 0 End Sub Private Sub CheckFindDate_Click() If Me.CheckFindDate.Value = True Then kh_SetDate Me.TextFind '''''''''''''''''''''''''''' End If End Sub Private Sub CommandButton1_Click() ActiveWorkbook.save Call MsgBox(" تم حفظ الكل بنجاح ", mBox, "الحمدلله") End Sub Private Sub CommandButton2_Click() ChaingeLanguage "Arabic" TextFind.SetFocus End Sub Private Sub CommandButton3_Click() ChaingeLanguage "English" TextFind.SetFocus End Sub Private Sub CommandButton4_Click() Me.TextFind.Value = "" End Sub Private Sub CommandButton6_Click() a = Application.Height - 10: b = Application.Width With Me .Width = .Width * 1.1 .Height = .Height * 1.1 .zoom = .zoom * 1.1 .Top = (a - .Height) / 2 .Left = (b - .Width) / 2 End With End Sub Private Sub CommandButton7_Click() a = Application.Height - 10: b = Application.Width With Me .Width = .Width / 1.1 .Height = .Height / 1.1 .zoom = .zoom / 1.1 .Top = (a - .Height) / 2 .Left = (b - .Width) / 2 End With End Sub Private Sub LabelH2_Click() Call MsgBox(" سيتم تحويل اي قيمة تضعها في مربع النص للبحث " _ & vbCr & vbCr & "الى تاريخ بالتنسيق الافتراضي للفورم ,,,,,,," _ & vbCr & String$(40, "=") _ & vbCr & vbCr & "مع امكانية ادخال رقم صحيح بين 1 الى 31 ليفهم على انه " _ & vbCr & vbCr & "تاريخ اليوم للشهر الحالي والسنة الحالية " _ , mBox + vbQuestion + vbApplicationModal, "تعليمات") ''''''''''''''''''''''''''' End Sub Private Sub ListFind_Click() Dim RR As Long RR = Me.ListFind.Column(1) Me.ScrollBar1.Value = RR End Sub Private Sub ScrollBar1_Change() Dim MyVelue Dim C As Integer, cc As Integer Me.Frame1.ScrollTop = 0 With Me.ScrollBar1 If ContRow = 0 Then .Min = 1 iRow = .Value: ContRow = .Max End With ''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) With MyRngdate If IsDate(.Cells(iRow + 1, C)) Then MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF) Else: MyVelue = .Cells(iRow + 1, C).Value2 End If End With On Error Resume Next Me.Controls("Textdt" & cc).Text = "" Me.Controls("Textdt" & cc).Text = MyVelue On Error GoTo 0 Next '------------------------------ Me.LabelSerial.Caption = iRow Me.LabelSerial2.Caption = iRow & " - " & ContRow kh_Enabled True End Sub Private Sub TextBox1_Change() End Sub Private Sub TextFind_Change() With Me.ListFind If .ListCount Then .Clear End With Me.LblFindCount = 0 Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False) End Sub Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) If Me.CheckFindDate.Value = False Then Exit Sub kh_SetDate Me.TextFind End Sub ' هذا الكود يرغمك بادخال تاريخ Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control) Dim dtest, dt dtest = dCntrl If Not IsDate(dtest) Then If IsNumeric(dtest) Then On Error Resume Next dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF) If Err Then dt = Format(Date, DtF) On Error GoTo 0 Else dt = Format(Date, DtF) End If Else: dt = Format(CDate(dtest), DtF) End If dCntrl = dt End Sub Private Sub TextSerial_Change() Dim v v = Me.TextSerial.Text If Len(v) = 0 Then Exit Sub If Not IsNumeric(v) Then GoTo 1 If v = 0 Or v > ContRow Then GoTo 1 Exit Sub '======================= 1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1) End Sub Private Sub TextSerial_AfterUpdate() If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = "" End Sub Private Sub kh_Enabled(ByVal Ebl As Boolean) Me.ButtonNewSave.Visible = Not Ebl Me.ButtonNewCancel.Visible = Not Ebl Me.ButtonNew.Visible = Ebl Me.ButtonSaveDate.Visible = Ebl '''''''''''''''''''''''''''''''''''''''''''' Me.ButtonPrint.Enabled = Ebl Me.ButtonSaveDate.Enabled = Ebl Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False) '''''''''''''''''''''''''''''''' Me.ButtonEnd.Enabled = CBool(iRow <> ContRow) Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1) Me.ButtonNewCancel.Enabled = IIf(iRow, True, False) Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl) End Sub Private Sub ButtonSerach_Click() Dim tb1 As Boolean, ib As Boolean Dim R As Long, RR As Long Dim C As Integer Dim MyFind, MySrch, MyVelue '''''''''''''''''''''' Me.ListFind.Clear If Len(Trim(Me.TextFind)) = 0 Then Exit Sub ''''''''''''''''''''' C = Me.BoxFind.ListIndex + 1 tb1 = CBool(Me.CheckFindDate.Value = True) If tb1 Then If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind MyFind = CDbl(CDate(Me.TextFind)) Else MyFind = Me.TextFind.Value End If ''''''''''''''''''''''' With MyRngdate.Cells(2, Ar(C)) For R = 1 To ContRow If Len(Trim(.Cells(R, 1))) Then If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare)) If ib Then MyVelue = .Cells(R, 1).Value If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Me.ListFind.AddItem MyVelue Me.ListFind.List(RR, 1) = R RR = RR + 1 End If End If Next End With Me.LblFindCount = Me.ListFind.ListCount If RR = 0 Then MsgBox " لا توجد نتائج لبحثك هذا ", mBox, "تنبيه" ''''''''''''''''''''''''' End Sub Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "") tSr = TypeName(Evaluate(aSr)) = "Range" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With ThisWorkbook If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr) Set MyRngdate = .Worksheets(MySht).Range(MyAddrs) End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With MyRngdate ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row LastColumn = .Cells.Count End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Col As Range Dim ii As Integer ReDim Ar(1 To LastColumn) For Each Col In MyRngdate.Cells ii = ii + 1 Ar(ii) = Col.Column - MyRngdate.Column + 1 Next ''''''''''''''''''''''''''' End Sub Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean If Not Rng.Comment Is Nothing Then MyList = Trim(Replace(Rng.Comment.Text, Chr(10), "")) MyList = Replace(MyList, " ", "") If TypeName(Evaluate(MyList)) = "Range" Then kh_TestType = True End If End If End Function Private Sub UserForm_Activate() Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double Dim MyBox As Control, MyLabl As Control Dim t As Integer Dim tTp As Boolean Dim MyType As String ''''''''''''''''''''' If tAc Then Exit Sub ''''''''''''''''''''' Me.Caption = MyRngdate.Worksheet.Name MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2) With Frame1 If MyScrollHeight > .Height Then .ScrollBars = 2 .ScrollHeight = MyScrollHeight End If End With MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2)) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' For t = 1 To LastColumn tTp = kh_TestType(MyRngdate.Cells(1, Ar(t))) MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1") Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True) With MyBox .Move Frmlft, MyTop, iWgt1, iHgt .TextAlign = 3 If tTp Then .BackColor = 16763955 .ControlTipText = "إختر من القائمة..تحياتى عبدالبارى البنا" On Error Resume Next .List = Range(MyList).Value If Err Then .AddItem Range(MyList).Cells(1, 1).Value On Error GoTo 0 End If If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then .BackStyle = 0 .TextAlign = 2 .SpecialEffect = 3 .Enabled = False End If End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True) With MyLabl .Move iWgt1 + Frmlft, MyTop, MyWith, iHgt .SpecialEffect = 3 .TextAlign = 2 .Caption = MyRngdate.Cells(1, Ar(t)) End With ''''''''''''''''''''''''''''''''''' Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2 MyTop = MyTop + iTop Next ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.BoxFind .Style = 2 .Tag = 1 .ListIndex = 0 End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.ScrollBar1 .Max = ContRow If ContRow Then .Min = 1 '.Value = ContRow Else kh_AddNewRecord End If End With tAc = True ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Me.TextBox1.Value = ورقة13.Range("f18").Value CheckFind.Value = True End Sub Private Sub UserForm_Initialize() Dim LaCouleur As String Dim Te LaCouleur = xlThemeColorLight1 Te = ("&&..الله اكبر..&& اهلا بكم فى برنامج شئون العاملين بالتربية والتعليم ........................إعداد وتصميم .. عبدالبارى البنا &&..ولله الحمد..&&") Me.WebBrowser1.Navigate _ "about:<html><body scroll='no'><font color= " & LaCouleur & " size='4' face='NEW'>" & _ "<marquee direction=right>" & Te & "</marquee></font></body></html>" 'Dim Zo% 'Dim ZH#, ZW#, AL#, AT#, AH#, AW# 'Dim FH!, FW! ''''''''''''''''''''''' 'AH = Application.Height: AW = Application.Width 'AL = Application.Left: AT = Application.Top 'FH = Height: FW = Width 'ZH = AH - FH: ZW = AW - FW: Zo = zoom 'If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW) ''''''''''''''''''''''' 'Move AL, AT, AW, AH 'If Zo <> 100 Then zoom = Zo '=========================================== iColor1 = Me.BackColor iColor2 = Me.Frame1.BackColor End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ' Me.TextBox1.Value = ورقة13.Range("f18").Value End Sub Private Sub UserForm_Terminate() Set MyRngdate = Nothing Erase Ar End Sub Private Sub WebBrowser1_StatusTextChange(ByVal Text As String) End Sub كود اخر ولا في الاحلام

السلام عليكم 🙂 لنا الشرف بالتعامل مع الخبير @دروب مبرمج 🙂 شكرا اخوي ابو ابراهيم ، وشكرا اخوي ابوخليل 🙂 جعفر

اذا كان النموذج مرتبط بمصدر بيانات فلا حاجة لامر حفظ وبمجرد الانتقال لسجل جديد او سابق وخلافه يحفظ الاكسس البيانات وهناك حالات معينة تكون اسنثناء

Hope this help you Sub Test() Const SROW As Long = 7 ' Start row constant, set to row 7 Dim ws As Worksheet, sh As Worksheet, rng As Range, lr As Long, r As Long Application.ScreenUpdating = False ' Disable screen updating to improve performance With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) ' Set variables ws and sh to the first and second worksheets in the workbook, respectively End With sh.Rows(SROW & ":" & Rows.Count).Cells.Clear ' Clear all cells in rows from SROW to the last row in worksheet sh lr = ws.Cells(Rows.Count, "C").End(xlUp).Row ' Find the last used row in column C of worksheet ws If lr < SROW Then Exit Sub ' If the last used row is less than the start row, exit the subroutine ws.Range("A" & SROW & ":G" & lr).Copy sh.Range("A" & SROW) ' Copy the range from column A to G, starting from SROW to lr, from worksheet ws to worksheet sh ws.Range("AN" & SROW & ":AN" & lr).Copy sh.Range("AN" & SROW) ' Copy the range in column AN, starting from SROW to lr, from worksheet ws to worksheet sh For r = SROW To lr ' Loop through each row from SROW to lr If sh.Cells(r, "AN").Value <> Join(Array(Chr(207), Chr(230), Chr(209), Chr(32), Chr(203), Chr(199), Chr(228), Chr(237)), Empty) Then ' Check if the value in column AN of the current row in worksheet sh is not equal to the joined characters If rng Is Nothing Then Set rng = sh.Rows(r) Else Set rng = Union(rng, sh.Rows(r)) ' If rng is Nothing, set rng to the current row, otherwise, combine rng with the current row using the Union function End If Next r If Not rng Is Nothing Then rng.EntireRow.Delete ' If rng is not Nothing (i.e., there are rows to be deleted), delete the entire rows of rng lr = sh.Cells(Rows.Count, "C").End(xlUp).Row ' Find the last used row in column C of worksheet sh If lr < SROW Then Exit Sub ' If the last used row is less than the start row, exit the subroutine sh.Range("A" & SROW).Resize(lr - SROW + 1).Value = Evaluate("ROW(1:" & lr - SROW + 1 & ")") ' Populate the range starting from cell A7 to the last used row in column C of worksheet sh with the row numbers using the Evaluate function Application.ScreenUpdating = True ' Enable screen updating End Sub

الف شكر استاذي الفاضل

Dim TR As HTMLTableRow If Not WD.activeElement.tagName = "body" And _ Not WD.activeElement.tagName = "div" Then For Each TR In WD.getElementsByTagName("tr") TR.Style.background = "" Next With WD.activeElement.parentElement .Style.background = "lightgreen" End With End If هذي ياعزيزي لتجاهل التركيز عند جسم الصفحة (Body Tag) وعند الحاوية (Div Tag) لأنها يمكن أن تكون العنصر النشط (ActiveElement) وقبول التركيز على خلايا الجدول (TD Tag) وعندها نقوم بتظليل الصف الذي يحوي هذه الخلايا.. لماذا هذه الحيلة؟! لأن الجداول والصفوف لا تقبل التركيز!!

جزاك الله خيرا ... على هذا المجهود

استاذي @jjafferr وحشتنا كتير

السلام عليكم 🙂 اي والله اشتقنا لكم 🙂 يجب اخذ اصل البيانات، استعمل هذه المعادلة: =Sum(((Nz([Quantity_of_cartons],0)*Nz([pieces in each caton],0))+Nz([JUST PIECES],0))*Nz([اسعار الجملة بالدولار],0)*[VAT_SALE]/100) او =Sum(((Nz([Quantity_of_cartons];0)*Nz([pieces in each caton];0))+Nz([JUST PIECES];0))*Nz([اسعار الجملة بالدولار];0)*[VAT_SALE]/100) جعقر

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

وعليكم السلام ورحمة الله وبركاته أخي حسين 🙂 تفضل : If t = b Then msgbox "القيمة الرقمية الموجود في حقل t تساوي القيمة التي في حقل b " ' "ثم تكتب هنا ما تريد من البنامج فعله لو تحقق الشرط" End If

تفضل استاد @محمد مصطفى درويش يمكنك استخدام الكود التالي مع الاخد بالاعتبار ان وقت تنفيد الكود من الممكن ان يصل الى دقيقتين او اكثر بسبب العدد الكبير للشيتات المحفوظة Sub Save_PDF() Dim i As Byte Path = ThisWorkbook.Path & "\" temps = Timer Application.ScreenUpdating = False Dim weekSheet As Worksheet For i = 8 To Worksheets.Count With Sheets(i).Select Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next Sheet1.Activate Application.ScreenUpdating = True MsgBox "تم حفظ" & " " & Application.Sheets.Count - 7 & " " & "بطاقة " & "-" & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000") & "ثانية", Exclamation, "Officena" End Sub ملف الطالب.rar

السلام عليكم و رحمة الله اجعل الدالة هكذا =COUNTIF(A1:A230;"<>"&"0")

السلام عليكم : الاعضاء الافاضل كل عام وانتم بخير .. بحلول شهر ذي الحجة اليكم . اداة ادراج التاريخ ... واستخدامها في الاكسل من خلال تواجدها في شريط الادوات للصفحة الرئيسية لكيفية استخدامها تابع الصور ... Datepicker.zip

جعله الله فى ميزان حسناتك

السلام عليكم تنقل بين الصفحات بكود من سطر واحد⚽ كود.xlsm

السلام عليكم شوف ده ... كاتب اكواد الفيجوال ملف منتشر لكن محتاج اساسيات وان لم تجد ضالتك ابحث في اليوتيوب عن تعلم الاكسل مع vba كاتب الاكواد.zip

Try this code Sub ToggleButton_ON_OFF() Const ONKEY As String = "On", OFFKEY As String = "Off" Dim ws As Worksheet, shOnOff As Shape, shToggle As Shape, shRadio As Shape, s As String Set ws = ActiveSheet With ws Set shOnOff = .Shapes("txtboxOnOff") Set shToggle = .Shapes("ToggleButton1") Set shRadio = .Shapes("radioButton") End With With shOnOff s = .TextFrame.Characters.Text .TextFrame.Characters.Text = IIf(s = ONKEY, OFFKEY, ONKEY) ws.Rows("12").Hidden = (s = OFFKEY) .TextFrame.HorizontalAlignment = IIf(s = ONKEY, xlHAlignLeft, xlHAlignRight) shToggle.Fill.ForeColor.RGB = IIf(s = ONKEY, RGB(232, 27, 34), RGB(117, 199, 1)) shRadio.Left = shToggle.Left + IIf(s = ONKEY, shToggle.Width - shRadio.Width - 5, 5) End With End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اسم المستخدم : admin كلمة المرور : 1989 Option Compare Text Dim f, Rng, MH(), WS_Rng, DataRng Private Sub UserForm_Initialize() DataRng = "Tableau1" WS_Rng = Range(DataRng).Columns.Count MH = Range(DataRng).Resize(, WS_Rng + 1).Value For i = 1 To UBound(MH): MH(i, WS_Rng + 1) = i: Next i Me.ListBox1.List = MH Me.ListBox1.ColumnCount = WS_Rng + 1 Me.ListBox1.ColumnWidths = "70;110;100;100;100" Me.ComboBox1.List = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) Me.ComboBox1.ListIndex = 0 Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, 1)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Sht = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) For i = 1 To WS_Rng Me("label" & i) = Sht(i, 1) Next i For i = WS_Rng + 1 To 6 Me("label" & i).Visible = False: Me("TextBox" & i).Visible = False Next i Me.ComboBox2 = "*" T_resultat = "عدد الموظفين" & "/" & ListBox1.ListCount + 0 Count = ListBox1.ListCount End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Combobox1_click() Me.ListBox1.List = MH Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Me.T.Caption = "بحث ب:" & Me.ComboBox1 Set Titre = Range(DataRng).Offset(-1).Resize(1) colFiltre = Application.Match(Me.ComboBox1, Titre, 0) Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, colFiltre)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Me.ComboBox2 = Empty End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub TextBoxRech_Change() On Error Resume Next WSdest = Me.ComboBox1.ListIndex + 1 clé = "*" & Me.TextBoxRech & "*": n = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, WSdest) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To n) For k = 1 To UBound(MH, 2): Tbl(k, n) = MH(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.clear End Sub منظومة-الشؤون-الادارية.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اليك حل بديل بالاكواد اول خطوة قم بتسمية نطاق عمود التصنيف بالشكل التالي =OFFSET(التعريف!$E$3;;;COUNTA(التعريف!$E:$E)-1) 2) وقم باظافة عنصر Combobox في اول خلية للقائمة المنسدلة G3 3) ضع هدا الكود في حدث شيت صفحة الادخال Dim F(), MH, Rng Private Sub ComboBox1_Change() Dim MH() MH = Application.Transpose([liste]) Me.ComboBox1.List = MH If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, MH, 0)) Then Me.ComboBox1.List = Filter(MH, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1 If ComboBox1.Value <> "" Then ComboBox1.BackColor = RGB(255, 255, 255) Else ComboBox1.BackColor = &HFFFF00 End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lr As Long Dim sh1 As Worksheet: Set sh1 = Worksheets("صفحة الادخال") Dim sh2 As Worksheet: Set sh2 = Worksheets("التعريف") lr = sh1.Range("A" & Rows.Count).End(xlUp).Row Set wsdata = Range("G3:G" & lr) If Not Intersect(wsdata, Target) Is Nothing And Target.Count = 1 Then If MH <> "" Then If IsError(Application.Match(Range(MH), F, 0)) Then Range(MH) = "" F = Application.Transpose(sh2.Range("Liste")) Me.ComboBox1.Height = Target.Height + 4 Me.ComboBox1.Width = Target.Width Me.ComboBox1.Top = Target.Top Me.ComboBox1.Left = Target.Left Me.ComboBox1 = Target Me.ComboBox1.Visible = True Me.ComboBox1.Activate MH = 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 Rng = ActiveCell If KeyCode = 13 Then If IsError(Application.Match(Rng, F, 0)) Then Rng = "" Rng.Offset(1).Select End If End Sub Private Sub ComboBox1_DropButtonClick() lr = Worksheets("التعريف").Cells(Rows.Count, 5).End(xlUp).Row ComboBox1.List = Sheet2.Range("E2:E" & lr).Value End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then ComboBox1.Value = "" End If End Sub 3) دوبل كليك على combobox وابحث باي حرف في اي مكان في السطر . حركة الصندوق.xlsb