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

السلام عليكم ورحمة الله أبدل في الكود العبارة "C:" بالعبارة "D:" في كل الأوامر...

السلام عليكم بها نبدأ أى مشاركة -بما انك لم تقم برفع ملف -فيمكنك استخدام هذا الكود لطلبك: Sub ColorCompanyDuplicates() Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim i As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next If xCell.Value <> "" Then xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 End If Next End Sub

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

استبدل المعادله في العامود G بهذه المعادله =IF(H5="";E5;0)+F5+D5

وعليكم السلام ورحمة الله وبركاته تفضل اخى جرب الملف الكود فى حدث الشيت Change Private Sub Worksheet_Change(ByVal Target As Range) Dim filterRange As Range Dim dataRange As Range Dim lastRow As Long Dim lastRow2 As Long Application.ScreenUpdating = False If Target.Address = "$P$4" Then lastRow2 = Cells(Rows.Count, "P").End(xlUp).Row Range("P6:V" & lastRow2 + 1).ClearContents If Not IsEmpty(Target.Value) Then lastRow = Cells(Rows.Count, "E").End(xlUp).Row Set dataRange = Range("A6:G" & lastRow) dataRange.AutoFilter Field:=5, Criteria1:="*" & Target.Value & "*" dataRange.Copy Range("P6") dataRange.AutoFilter End If End If Application.ScreenUpdating = True End Sub Data.xlsm

شكرا لحضرتك اكفيت ووفيت بارك الله فيك

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

كل التقدير

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

هذه المشكلة شائعة ومعروفة : يحدث خطأ عندما تكون قيمة احد الحقول المجموعة فارغة ويتم تجاوز هذا الخطأ بتحويل قيمة الحقل الى صفر عندما يكون خاليا وذلك باستخدام الدالة NZ ونستخدمها كالتالي في جميع الحقول مثلا : =[ZZ1].[Form]![ZZ] تصبح هكذا : =NZ(=[ZZ1].[Form]![ZZ]);0)

السلام عليكم ورحمة الله وبركاته اليكم برنامج الجرد خاص بالمصالح الاقتصادية دمتم في رعاية الله وحفظه. برنامج الجرد العام 2022 (2).rar

شكرا لكم و أعتذر عن الرد كلمة سر محرر الأكواد هي : baba

جرب الكود التالى Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$8" Or Target.Address = "$F$8" Then Dim LastRow As Long Dim FilterRange As Range Dim FilterColumn As Long If Target.Address = "$D$8" Then FilterColumn = 2 ElseIf Target.Address = "$F$8" Then FilterColumn = 4 End If LastRow = Me.Cells(Rows.Count, "D").End(xlUp).Row Set FilterRange = Range("C9:U" & LastRow) If Not IsEmpty(Target.Value) Then FilterRange.AutoFilter Field:=FilterColumn, Criteria1:=Target.Value Else FilterRange.AutoFilter Field:=FilterColumn End If End If End Sub

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

Database3.accdb

@engc2011e هو حضرتك بردو مهندس مدني ؟ ياسلام ...صرنا اثين ...حنكون تحالف 😂

تفضل اخي تم تعديل الاكواد لتتناسب مع طلبك . Private Sub Worksheet_Change(ByVal Target As Range) ''''''''''''''''''''''''''' الخزينة 1 '''''''''''''''''''''''''''''''' On Error Resume Next ' 'اظافة شرط الفلترة لزر التصفية If Not Intersect(Target, Range("j3")) Is Nothing Then Add_text If Not Intersect(Target, Range("D3")) Is Nothing Then Dim LRow As Long, Réf As Range, data As Range Dim WSData As Worksheet: Set WSData = ThisWorkbook.Sheets("الخزينة1") 'اسم عمود البحث Col = WSData.Range("D3").Text 'خلية القائمة المنسدلة Set cel = [j3] Application.ScreenUpdating = False Application.Calculation = xlManual 'الغاء الفلترة WSData.ShowAllData 'نطاق البحث Set Réf = WSData.Range("D6:O6").Find(Col) If Not Réf Is Nothing Then On Error Resume Next ' افراغ البيانات السابقة WSData.Range("Ad7:Ad" & Range("Ad7").End(xlDown).Row).ClearContents LRow = WSData.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row 'نسخ العمود الهدف WSData.Range(WSData.Cells(7, Réf.Column), WSData.Cells(3325, Réf.Column)).Copy With WSData 'لصق .Range("AD7").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False 'ترتيب ابجدي (رقمي) WSData.Range("AD7:AD" & LRow).Sort Key1:=Range("AD7"), Order1:=xlAscending, Header:=xlNo 'ازالة الفراغات WSData.Range("ad7:ad" & LRow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 'ازالة التكرار WSData.Range("AD7", .Cells(.rows.Count, 30).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo [j3].NumberFormat = [AD7].NumberFormat End With ' اظافة قائمة منسدلة مطاطية Set data = Range(Range("Ad7"), Range("Ad" & rows.Count).End(xlUp)) With cel.validation .Delete .Add Type:=xlValidateList, Formula1:="=" & data.Address & "" [j3] = [AD7] End With End If End If [d6].Select Application.CutCopyMode = False Application.Calculation = xlAutomatic On Error GoTo 0 End Sub الخزينة6.xlsb

وعليكم السلام -طبعاً وبالتأكيد هذا مجهد ومتعب حتى لو كان الشخص محترف الإكسيل -أقترح عليك من الأفضل طبعاً عمل وفتح 12 صفحة بعدد شهور السنة ثم عمل صفحة أساسية للمدخلات اليومية ومنها يتم ترحيل كل مدخلات للشهر الذى يخصه وأعتقد ان هذا سيكون أفضل وأسهل بكثير وليس هناك داعى طبعاً لعمل صفحة لكل يوم لأنك بالتالى ستحتاج فتح أكثر من 360 صفحة بالملف مما سيجعل العمل على هذا الملف بطىء جداً وشكراً لكم-وذلك بإستخدام هذه المعادلة بجميع شيتات الشهور ... كما ان هناك صفحة تسمى Summary بها تجميع لكل شهر على حده =IFERROR(INDEX(Input!$A$5:$I$1000,AGGREGATE(15,6,(ROW(Input!$B$1:$B$1000)/(Input!$H$5:$H$1000=MID(CELL("filename",$A$1),FIND("]",CELL("filename",$A$1),1)+1,LEN(CELL("filename",$A$1))-FIND("]",CELL("filename",$A$1),1)))),ROWS(January!$A$1:A1)),MATCH(January!A$5,Input!$A$5:$I$5,0)),"") جميع مبيعات السنة-بالمعادلات.xlsm

السلام عليكم ورحمة الله و بركاته اليوم سوف أختصر عليكم الكلام ملف RGB محول الألون جميل وسهل لمعرفة أكواد الألوان لذا سأترككم مع الملف أخوكم في الله المبرمج : مناد سفيان الجزائر. convert_hex_to_rgb.xls

وعليكم و رحمة الله و بركاته للاغلاق نموذج الاول اولاً ثم فتح النموذج الثاني عليك تعريف المتغير برقم ID في نموذج الاول و ثم وضع اسم المتغير في الشرط بدل ID لاحظ الكود On Error Resume Next Dim IDv As Integer IDv = id DoCmd.Close DoCmd.OpenForm "form2", , , "[ID]=" & IDv

الاخوة الافاضل السلام عليكم ورحمة الله وبركاته يكفينا أمر إغلاق الفورم بدون ذكر أسمه ثم أمر فتح فورم آخر مثال : DoCmd.Close DoCmd.OpenForm "main"" فالايعاز الأول يغلق الفورم الحالي والثاني يقوم بفتح الفورج الجديد بعد غلق القديم

اخي العزيز لا يمكن تحميل ملفك ولكن على العموم في حدث on click في زر الامر ضع الكود التالي "اسم النموذج المراد فتحه" DoCmd.OpenForm "اسم النموذج المراد اغلاقه" ,DoCmd.Close acForm ثم نفس الكود مع تغيير اسماء النماذج ملاجظة : كود الفتح قبل كود الاغلاق وهذا اجباري