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

اخي الكريم أنشئ 3 مربعات نص واجعل اسمائهم كالتالي ( Text1 و Text2 و Text3 ) استخدم الكود التالي في حدث عند التحميل للنموذج Dim db As DAO.Database Dim rs As DAO.Recordset Dim strSQL As String Dim formName As String Dim totalSalary As Double strSQL = "SELECT [اسم العامل], SUM(راتب) AS مجموع_الرواتب FROM جدول1 GROUP BY [اسم العامل];" formName = Me.Name Set db = CurrentDb Set rs = db.OpenRecordset(strSQL) Do While Not rs.EOF If rs![اسم العامل] = "محمد" Then Forms(formName).Controls("Text1").Value = rs!مجموع_الرواتب ElseIf rs![اسم العامل] = "علي" Then Forms(formName).Controls("Text2").Value = rs!مجموع_الرواتب ElseIf rs![اسم العامل] = "كمال" Then Forms(formName).Controls("Text3").Value = rs!مجموع_الرواتب End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing ونصيحة من أخوك ، ابتعد عن المسميات العربية في اسماء الحقول والكائنات ... الخ

حل اخر مع اليوم الافتراضي لبداية الاسبوع بالنسبة لي . Sub GroupWeek_2() Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = Sheet1 Dim desWS As Worksheet: Set desWS = Sheet2 desWS.Cells.ClearContents: Cells.Interior.ColorIndex = xlNone ws.Range("A1:B1", ws.Range("a" & Rows.Count).End(xlUp)).Copy desWS.Range("A1") GroupByWeek desWS, "a2", "a", "اسبوع " End Sub Sub GroupByWeek( _ ByVal desWS As Worksheet, _ ByVal Clé As String, _ Optional ByVal GroupColumn As Variant = "a", _ Optional ByVal GroupBaseName As String = "اسبوع ") Dim f As Range, IRow As Long, lr& Dim Rng As String Dim minDate As Date, maxDate On Error Resume Next IRow = desWS.Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 minDate = Application.WorksheetFunction.Min(desWS.Range("A2:A" & IRow)) maxDate = Application.WorksheetFunction.Max(desWS.Range("A2:A" & IRow)) With Range("a2:a" & IRow) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Exit Sub End If End With Dim fCell As Range: Set fCell = desWS.Range(Clé) Dim lCell As Range Set lCell = fCell.Resize(desWS.Rows.Count - fCell.Row + 1) _ .Find("*", , xlFormulas, , , xlPrevious) If lCell Is Nothing Then Exit Sub Dim rCount As Long: rCount = lCell.Row - fCell.Row + 1 Dim crg As Range: Set crg = fCell.Resize(rCount) Dim Data As Variant If rCount = 1 Then ReDim Data(1 To 1, 1 To 1): Data = crg.Value Else Data = crg.Value End If ReDim Preserve Data(1 To rCount, 1 To 2) Dim CurrValue As Variant Dim CurrDate As Date Dim OldWeek As Long Dim NewWeek As Long Dim sr As Long Dim Cpt As Long For sr = 1 To rCount CurrValue = Data(sr, 1) If IsDate(CurrValue) Then NewWeek = Application.WeekNum(CurrValue) If NewWeek <> OldWeek Then Cpt = Cpt + 1 Set Data(Cpt, 1) = crg.Cells(sr) Data(Cpt, 2) = NewWeek OldWeek = NewWeek End If End If Next sr If Cpt = 0 Then Exit Sub For Cpt = Cpt To 1 Step -1 With Data(Cpt, 1) .EntireRow.Insert xlShiftDown .Offset(-1).EntireRow.Columns(GroupColumn).Value _ = GroupBaseName & Data(Cpt, 2) End With Next Cpt Dim ar As Range For Each ar In desWS.Range("b2:b" & desWS.Range("b" & Rows.Count).End(xlUp).Row + 1).SpecialCells(xlCellTypeConstants).Areas ar.Offset(-1).Resize(1).Value = WorksheetFunction.Sum(ar) Next lr = desWS.Columns("A:b").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 With desWS.Range("a2:a" & lr) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Rng = f.Address Do desWS.Range("a:b").Rows(f.Row).Interior.ColorIndex = 8 f.Interior.ColorIndex = 45 Set f = .FindNext(f) ' Loop While f.Address <> Rng End If End With Application.ScreenUpdating = True MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub مجموع كل أسبوع V2.xlsm

لتجميع البيانات أسبوعياً، يمكنك استخدام الصيغ الشيتية في Excel للتجميع. يمكنك اتباع الخطوات التالية: 1. إضافة عمود جديد لتحديد الأسبوع. 2. في الخلية A2، اكتب الصيغة التالية لاستخراج تاريخ الأسبوع: ``` =TEXT(A2, "ww") ``` حيث A2 هو الخلية التي تحتوي على التاريخ. 3. في الخلية C2، اكتب الصيغة التالية لجمع البيانات الأسبوعية: ``` =SUMIF($A$2:$A$35, "="&A2, $B$2:$B$35) ``` حيث A2:A35 تحتوي على تواريخ الأسابيع، وB2:B35 تحتوي على القيم المرتبطة. 4. اسحب الصيغتين لأسفل لتطبيقهما على بقية الصفوف. هذا سيقوم بتجميع القيم الأسبوعية في العمود C حسب الأسبوع المحدد. جرب إذا كنت ترغب في استخدام VBA لتجميع البيانات أسبوعيًا، يمكنك استخدام الكود التالي. يفترض أن لديك بيانات في الأعمدة A و B، وترغب في تجميعها أسبوعيًا في أعمدة C وD Sub AggregateWeekly() Dim ws As Worksheet Dim lastRow As Long Dim weekStartDate As Date Dim totalSales As Double Dim targetRow As Long ' Set the worksheet Set ws = ThisWorkbook.Sheets("Sheet1") ' Find the last row with data lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Initialize variables totalSales = 0 targetRow = 2 ' Start from row 2 (assuming row 1 is headers) ' Loop through the rows For i = 2 To lastRow ' Check if the current date is in the same week as the start date If Weekday(ws.Cells(i, 1).Value, vbMonday) = 2 Then ' Add the sales to the total totalSales = totalSales + ws.Cells(i, 2).Value End If ' If the current date is the last day of the week or the last row, write the total sales for the week If Weekday(ws.Cells(i, 1).Value, vbMonday) = 1 Or i = lastRow Then ' Write the week start date ws.Cells(targetRow, 3).Value = ws.Cells(i, 1).Value - Weekday(ws.Cells(i, 1).Value, vbMonday) + 1 ' Write the total sales for the week ws.Cells(targetRow, 4).Value = totalSales ' Move to the next row targetRow = targetRow + 1 ' Reset the total sales for the next week totalSales = 0 End If Next i End Sub هذا الكود يقوم بتجميع البيانات الأسبوعية ووضعها في أعمدة جديدة. يمكنك تعديل اسماء الاعمدة والورقة حسب احتياجك.

جزاك الله خيرا يا صديقي 🥰 هذا ما لمحت له في كلامي

جدولك ليس فيه تواريخ ؟؟؟؟ ولكن ماذا لو كانت الاسماء كثيرة ؟؟؟؟؟؟ مشاركة مع حبيبنا الاستاذ @Foksh جرب هذه الطريقة !!!!! مثال (5).accdb

السلام عليكم ورحمة الله وبركاته اسف للتعليق بعد الإجابات والانتهاء من الموضوع أعتقد من الأفضل هو تغيير التنسيق ليكون تنسيق كسور فمثلا في الصيغة الرائعة التي وضعها استاذنا وعبقري الإكسيل أ/ حسونة لو انني غيرت مثلا L10 الى رقم 120 يكون الناتج كالآتي 8/16 7 أما من خلال التنسيق سيظهر الرقم 1/2 7 وأعتقد هذا أوقع وشكرا لسعة صدركم فتكون المعادلة عادية جدا وباسعل طريقة كما في شيت الإكسيل الأصلي =L10/N10 ولكن فقط نغير تنسق الخلية التي يظهر فيها الناتج كالتالي

، مع انك لو قرأت الكود الذي هو أصلاُ في مشروعك وليس مني لعرفت اين حل مشكلتك ,, على العموم الإضافة بسيطة جداً ، تفضل Me.nn1 = "A" & Me.nn add attachment.accdb

السلام عليكم كل شيء تمام 100% استاذي العزيز @Foksh شكرا لك على مجهودك الكبير الله يجعلها في ميزان حسناتك استاذي العزيز @ناقل الله يبارك فيك والله يجعلها في ميزان حسناتك استاذ العزيز والكبير @ابوخليل تحية اعتزاز وامتنان لك الله يجعلها في ميزان حسناتك بارك الله فيكم جميعا اخوكم احمد

وعليكم السلام ورحمة الله وبركاته تفضل اخى لعلها طلبك =ROUNDDOWN(L10/N10,0) & " " & L10-SUM(ROUNDDOWN(L10/N10,0)*N10) & "/" & N10

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

وعليكم السلام ورحمة الله تعالى وبركاته مجرد فكرة ربما تناسبك Public Sub Split_Sheet_By_Weekly_Date_Ranges() Dim desWS As Worksheet, WS As Worksheet: Set WS = Sheet1 Dim lr As Long, minDate As Date, maxDate Dim WeekStar As Date, desWSName As String With Application .ScreenUpdating = False .DisplayAlerts = False For Each SH In Worksheets If SH.Name <> WS.Name Then Application.DisplayAlerts = False SH.Delete End If Next With WS lr = .Cells(.Rows.Count, "A").End(xlUp).Row minDate = Application.WorksheetFunction.Min(.Range("A2:A" & lr)) maxDate = Application.WorksheetFunction.Max(.Range("A2:A" & lr)) End With WeekStar = Date_Prev_Saturday(minDate) While WeekStar <= maxDate desWSName = Format(WeekStar, "dd-mm") & " To " & Format(WeekStar + 6, "dd-mm") With ActiveWorkbook Set desWS = Nothing On Error Resume Next Set desWS = .Worksheets(desWSName) On Error GoTo 0 If desWS Is Nothing Then Set desWS = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)) desWS.Name = desWSName desWS.DisplayRightToLeft = True End If End With desWS.[A1:B1].Value = Array(WS.[A1].Value) desWS.[A2:B2].Value = Array(">=" & CLng(WeekStar), "<=" & CLng(WeekStar) + 6) WS.Range("A1:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=desWS.[A1:B2], CopyToRange:=desWS.[A4], Unique:=False desWS.Columns("A:B").AutoFit IRow = desWS.Cells(Rows.Count, "a").End(xlUp).Row + 1 With desWS.Range("A2:B" & IRow) .Cells(IRow - 1, "b").Formula = "=SUM(b5:b" & IRow - 1 & ")": .Cells(IRow - 1, "a").Value = "المجموع" .HorizontalAlignment = xlCenter .Value = .Value With Range("A" & IRow & ":B" & IRow).Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End With desWS.Rows("1:3").Delete Shift:=xlUp If desWS.[A3] = "" Then desWS.Delete WeekStar = WeekStar + 7 Wend WS.Activate DisplayAlerts = True .ScreenUpdating = True End With MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub 'Given a date, return the date of the preceding Saturday, or the date itself if it is a Saturday Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function مجموع كل أسبوع على حدة.xlsm

عيني عليك بارده من الحسد 🥰 ومنكم نتعلم وما زلنا معلمنا الفاضل @ابوخليل جزاك الله كل خير 🤝 انا كنت فاهم باتجاه آخر 😅

انا كنت اعمل على الكود لما رأيت كود الاستاذ فادي وقرأته اعتقدت انه يلبي المطلوب وتوقفت عن اكمال الكود الآن وبعد تأكيد ما فهمته من قبل الاستاذ احمد اليكم الحل دالة تأخذ قيمة B وتقارنها بأي حقل داخل السجل : Public xfld As Byte Public Function Allfld(x As String) As String On Error GoTo ErrHandler Dim rs As Object, i As Integer Set rs = CurrentDb.OpenRecordset("SELECT TP2.* FROM TP2 WHERE TP2.GradeNO= " & [Forms]![form1]![A] & "") i = 0 For Each Field In rs.Fields i = i + 1 If x = rs.Fields(i) Then xfld = 1 Exit Function End If Next Set rs = Nothing ErrHandler: If Err.Number = 3256 Then Exit Function End If End Function ويتم مناداتها من النموذج : Private Sub B_AfterUpdate() xfld = 0 Call Allfld(Me.B) If xfld = 0 Then MsgBox "البيانات غير متطابقة" Undo Exit Sub End If End Sub Test-11.rar

أستاذ @Ahmed_J ، خليني افهم حبة حبة لأن احياناً استيعابي يكون بطيء حبتين بعد الأكل .. هالحين انت محتاج من تختار من القائمة B يروح يعمل بحث في كل الحقول - حتى لو عددهم 50 - اللي سجلها رقمه يطابق GradeNo في القائمة A . انا عملت الـ GradeNo رقم 8 يساوي كاتب في الحقلين باعتبار وجود أكثر من حقل في الجدول . وعند اختيار رقم 8 من النموذج من A وتختار اي اختيار في B غير كاتب رح تكون النتيجة انه عدم تطابق في البيانات .. ومن تختار كاتب ما رح يظهر رسالة . الحين هذا اللي انا دخت وأنا أشرحه صحيح ولا لا سمح الله غلط . هذا الكود اللي خرجت فيه بالنهاية ، والمرفق أسفله :- Private Sub B_AfterUpdate() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Dim found As Boolean Dim field As DAO.field found = False Set db = CurrentDb sql = "SELECT * FROM TP2 WHERE GradeNo = " & Me.A Set rs = db.OpenRecordset(sql) If Not rs.EOF Then found = True rs.MoveFirst For Each field In rs.Fields If field.Name <> "GradeNo" And field.Value <> Me.B Then found = False Exit For End If Next field End If rs.Close If found Then MsgBox "بيانات متطابقة", , "" Else 'If Not found Then MsgBox "بيانات غير متطابقة", , "" End If End Sub Test-1.accdb

يمكنك استخدام الدالة التالية للتحقق من تكرار الأسماء لنفس الرقم =IF(COUNTIF(A:A, A2) > 1, "تنبيه: تكرار اسم", "") هذه الدالة تقوم بفحص العمود A (الذي يحتوي على أرقام الهوية) للصف الحالي (الذي يتمثل في A2 في هذا السياق). إذا وجدت أكثر من قيمة واحدة متطابقة مع قيمة الخلية A2، فإنها تُعيد "تنبيه: تكرار اسم"، وإلا فإنها تعيد "" (لا شيء).

من داخل النماذج

تفضل أخي الكريم .,, عدم تكرار .accdb

ادن اخي يجب التحقق اولا من تنسيق خلية اسم الشهر .اليك الملف عليه الكود يمكنك تطويعه بما يناسبك Sub Filter_month() Dim lr&, i&, j&, c& Dim arr As Variant, K As Variant Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("1") Dim desWS As Worksheet: Set desWS = ThisWorkbook.Sheets("2") lastrow = desWS.Range("b" & Rows.Count).End(xlUp).Row clé = desWS.[L2] If clé = 0 Then MsgBox "المرجوا تحديد شهر الفلترة", vbExclamation: Exit Sub Application.ScreenUpdating = False lr = WS.Range("B" & Rows.Count).End(xlUp).Row On Error Resume Next arr = WS.Range("A3:L" & lr).Value ReDim K(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) If Month(arr(i, 2)) = Month(clé) Then desWS.Range("B5:M" & Rows.Count).ClearContents For c = LBound(arr, 2) To UBound(arr, 2) K(j, c) = arr(i, c) Next c j = j + 1 End If Next i desWS.Range("b5").Resize(j - 1, UBound(K, 2)).Value = K If Err <> 0 Then MsgBox "لا توجد بيانات لشهر" & " :" & Month(clé), vbExclamation, "admin" End Sub Filter_month.xlsb

هذه تجربتي البسيطة ، بالإستناد إلى برنامج صغير يقوم بصناعة الـ QR كما ترغب ، يدعم قراءة اللغة العربية بدون مشاكل . وتم ضبط البحث MedicalCenter.zip

تفضل Counter1.xls