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

وعليكم السلام ورحمة الله تعالى وبركاته Sub CreateSheets() Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1") Dim MyRng As Range, RngCopy As Range, Sh As Collection Dim cell As Range, DerLig As Long Dim wsDest As Variant, s As String Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False End With For Each WS In Sheets If WS.Name <> mydata.Name Then WS.Delete Next On Error Resume Next For Each cell In MyRng.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each wsDest In Sh s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With mydata DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row .Range("A5").AutoFilter field:=3, Criteria1:=wsDest Set RngCopy = .Range("A5:C" & DerLig) RngCopy.Copy Sheets(s).Range("A5") .Select .[A5].AutoFilter End With Next wsDest For Each wscopy In ThisWorkbook.Worksheets If wscopy.Name <> mydata.Name Then For i = 1 To 3 wscopy.Cells.EntireRow.AutoFit wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight wscopy.Columns("B:B").ColumnWidth = 70 wscopy.Activate With ActiveWindow .SplitRow = 5 .SplitColumn = 0 .FreezePanes = True End With Next End If Next wscopy mydata.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub اسلاميات 2.xlsm

يتم دالك بسبب نسخ قيمة Textbox مكان المعادلة هناك 2 حلول اما استبدال الكود بكود يتوافق مع شكل وتصميم الملف او تعديله بالطريقة التالية وهي الاستغناء عن وضع المعادلة يدويا وتعويضها بواسطة الاكواد على النحو التالي Private Sub CommandButton3_Click() Dim DerLig As Long, X As Long Dim WSData As Worksheet: Set WSData = ActiveSheet DerLig = WSData.Range("C" & WSData.Rows.Count).End(xlUp).row Application.ScreenUpdating = False If Me.TextBox1.Value = Empty Then: Exit Sub X = Application.Match(Val(TextBox1.Value), WSData.Columns("C"), 0) If Not IsError(X) Then For i = 2 To 18 WSData.Cells(X, i + 2).Value = Controls("TextBox" & i).Value WSData.Cells(X, i + 2).Value = WSData.Cells(X, i + 2).Value Next i End If For r = 1 To 18 Me("Textbox" & r) = "" Next r WSData.Range("C10").Value = 1 WSData.Range("C10:C" & DerLig).DataSeries , xlDataSeriesLinear ' وضع المعادلة WSData.Range("P10:P" & DerLig).Formula = "=IF(N10="""","""",""(""& O10&"" / ""&N10&"")"")" With WSData.Range("P10:P" & DerLig) .Value = .Value End With End Sub مني 4.xlsm

طيب ليش ما يتم في الجدول من الاساس ... على كل حال تم التعديل حسب طلبك في المرفق ... انظر times24.accdb

يمكنك استثناء اوراق العمل الاخرى داخل الكود بالطريقة التالية Sub CreateSheets() Dim mydata As Worksheet: Set mydata = ThisWorkbook.Sheets("Sheet1") Dim MyRng As Range, RngCopy As Range, Sh As Collection Dim cell As Range, DerLig As Long, ws As Worksheet Dim wsDest As Variant, s As String, SheetName As String Set MyRng = mydata.Range("C6:C" & mydata.Cells(mydata.Rows.Count, "C").End(xlUp).Row) Set Sh = New Collection With Application .ScreenUpdating = False .DisplayAlerts = False End With '*********' قم باظافةاسماء اوراق العمل الغير مرغوب حدفها من المصنف هنا************** SheetName = "Sheet1,Sheet2" '*********************************************************************************** Application.ScreenUpdating = False For Each ws In Worksheets If InStr(1, SheetName, ws.Name) = 0 Then Réf = Application.Match(ws.Name, arr, 0) If IsError(Réf) Then ws.Delete End If End If Next ws On Error Resume Next For Each cell In MyRng.Cells Sh.Add cell.Value, CStr(cell.Value) Next cell On Error GoTo 0 For Each wsDest In Sh s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With mydata DerLig = .Cells(.Rows.Count, "C").End(xlUp).Row .Range("A5").AutoFilter field:=3, Criteria1:=wsDest Set RngCopy = .Range("A5:C" & DerLig) RngCopy.Copy Sheets(s).Range("A5") .Select .[A5].AutoFilter End With Next wsDest For Each wscopy In Worksheets If InStr(1, SheetName, wscopy.Name) = 0 Then Réf = Application.Match(wscopy.Name, arr, 0) If IsError(Réf) Then For i = 1 To 3 wscopy.Cells.EntireRow.AutoFit wscopy.Columns(i).ColumnWidth = mydata.Columns(i).ColumnWidth wscopy.Rows("5:5").RowHeight = mydata.Rows("5:5").RowHeight wscopy.Columns("B:B").ColumnWidth = 70 wscopy.Activate With ActiveWindow .SplitRow = 5 .SplitColumn = 0 .FreezePanes = True End With Next End If End If Next wscopy mydata.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub اسلاميات 3.xlsm

ما فيه شي اسمه تنطرح كما تفضل اخوي موسى : ولكن بدون استعلامات تخصيص جدول لتفاصيل الاجازات عمل حقلين فيه: 1- حقل الاستحقاق السنوي ، ويتم الادراج فيه بداية كل سنة 30 يوما 2- حقل المنصرف او الاستمتاع او المستقطع "" سمه ما شئت"" يرصد فيه عدد ايام الاجازة التي يتمتع بها الموظف من خلال مجموع الحقلين يمكنك معرفة الارصدة المتبقية واجراء العمليات من واقعها

السلام عليكم ورحمه الله وبركاته راجع الموضوع ادناه

أخي بارك الله فيك والله هذا ما أريد بالتفصيل جزاك الله خير الجزاء وجعلها في ميزان حسناتك و يسر أمورك أخي أنا أردت هكذا لأن الطلبة عندما تكون المادة: علم الأحياء أو علوم تكون قاعة الدراسة مشتركة رقم 50 بالنسبة لجميع الدرجات ما عدا ذلك يدرسون في قاعات الدراسة roomالموجودة في الجدول. فشكرا مرة أخرى

الافضل ان تثبت التواريخ في الجدول جرب هذه المحاولة stlist.accdb

جرب هذه الفكرة البسيطة stlist.accdb

الفكرة جميلة ، وقد يكون هناك فكرة ، سأجربها وأعطيك الرد 🙂

لم أقم بتجربة هذا الكود ، انشئ وحدة نمطية جديده واكتب الكود فيها :- Function GetConnectedDevices() Dim objShell As Object Dim objExec As Object Dim strCommand As String Dim strOutput As String Set objShell = CreateObject("WScript.Shell") strCommand = "arp -a" ' يمكك استبداله بأمر آخر حسب نوع الشبكة الخاصة بك Set objExec = objShell.Exec(strCommand) strOutput = objExec.StdOut.ReadAll GetConnectedDevices = strOutput End Function جرب استدعاء الكود بمربع نص مثلا عن طريق GetConnectedDevices()

نعم اخي يمكنى فعل ذالك ولاكن بعض موافقة مشرفي المنتدى

ماشاء الله هو المطلوب تمام جزاك الله كل خير

ربما قوانين المنتدى لا تسمح بدالك لضمان حقوق الملكية لصاحب الملف نعم اخي يمكنا فعل دالك بعض موافقة مشرفي المنتدى

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

اخي الكريم احب اساعدك بطريقة اكاديمية البرمجة تتم تنفيذا لتصور عملية او فكرة محددة فانت هنا تريد ان تمنح الزبون قطعة مجانية مقابل شراء قطعتين ، واحيانا تمنح قطعة مقابل قطعة ، واحيانا قطعة مقابل 3 او 4 او 5 .... الخ ومن اجل تكون العملية مرنة عند البيع وعند الحسابات يلزم وضع آلية وتحكم لهذا الإجراء اسهل واقرب آلية هي : في جدول الاصناف : عمل حقل تضع فيه نسبة محددة امام الصنف المستهدف ، يتم تحديثه او حذفه حسب الحال عمل حقل آخر للحد الأدنى لعدد القطع المشتراه ما زاد عن ذلك يكون السعر تبعا للنسبة .. في مثالك اذا اشترى ثلاث سيدفع قيمة اثنتين واذا اشترى 6 سيدفع قيمة اربع اذا اشترى 5 او 7 فالدفع سيكون حسب النسبة وبهذه الطريقة تكون الأمور دقيقة وواضحة امام مدقق الحسابات

تفضل استاذ @sm44ms الشرح بفورم1 + أكواد الألوان . اذا كان هذا طلبك لا تنسى الضغط على أفضل اجابة . DD227-2.accdb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Recherche() Dim lastrow As Long, Col As Long Set wsdest = ThisWorkbook.Sheets("Feuil1") Set wsdata = ThisWorkbook.Sheets("Feuil2") lastrow = wsdata.Cells(Rows.Count, "C").End(xlUp).Row If Application.WorksheetFunction.CountA(wsdest.Range("AE7:AM7")) = 0 Then MsgBox "!!!المرجوا إدخال معايير الفلترة " & vbCrLf, vbInformation + vbOKOnly, " ! تنبيه" Exit Sub End If Application.ScreenUpdating = False ' إلغاء حماية الورقة wsdest.Unprotect "0000" If wsdest.AutoFilterMode Then wsdest.AutoFilterMode = False Col = wsdest.Cells(Rows.Count, "AE").End(xlUp).Row ' افراغ البيانات السابقة wsdest.Range("AE15:AM" & Col).Clear 'Contents 'نطاق الفلترة wsdata.Range("C27:K" & lastrow).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsdest.Range("AE6:AM7"), _ CopyToRange:=wsdest.Range("AE14:AM14"), _ Unique:=True If Application.WorksheetFunction.CountA(wsdest.Range("AE15:AM15")) = 0 Then résultat = MsgBox("ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه") End If On Error Resume Next ' اخفاء الصيغ wsdest.UsedRange.SpecialCells(xlCellTypeFormulas).FormulaHidden = True On Error GoTo 0 ' ارجاع الحماية لورقة العمل wsdest.Protect "0000" Application.ScreenUpdating = True End Sub التقرير-اليومي 2022 مبرمج.xlsm

تفضل اخي يمكنك اختيار ما يناسبك Option Explicit ' الغاء فلترة جميع اوراق العمل Sub Sup_tous_les_filtres() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode = True Then Debug.Print WS.Name WS.AutoFilterMode = False End If Next End Sub '**********او*********** Sub Sup_tous_les_filtres2() Dim WS As Worksheet For Each WS In Worksheets If WS.AutoFilterMode Then WS.AutoFilter.Range.AutoFilter End If Next End Sub '********تحديد تسلسل معين *********** Sub vSup_tous_les_filtres3() Dim i As Long Dim compteur As Long ' عدد اوراق العمل compteur = 100 ' من ورقة 1 الى 100 For i = 1 To compteur On Error Resume Next If Sheets(i).AutoFilterMode Then Sheets(i).AutoFilter.Range.AutoFilter On Error GoTo 0 End If Next i End Sub