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

وعليكم السلام ورحمة الله تعاى وبركاته اقتراح اخر Option Explicit Sub test() Dim lastRow, i As Long, OnRng, tmp, key As Variant Dim name As String, amount As Double, dict As Object Dim WS As Worksheet: Set WS = Sheets("ورقة1") With WS lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Exit Sub Set dict = CreateObject("Scripting.Dictionary"): OnRng = .Range("B2:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) name = Trim(OnRng(i, 1)): amount = OnRng(i, 2): If name <> "" Then dict(name) = dict(name) + amount Next i Application.ScreenUpdating = False .Range("E2:F" & lastRow).ClearContents If dict.Count = 0 Then: Exit Sub ReDim tmp(1 To dict.Count, 1 To 2) i = 1 For Each key In dict.keys tmp(i, 1) = key: tmp(i, 2) = dict(key): i = i + 1 Next key .Range("E2").Resize(dict.Count, 2).Value = tmp Application.ScreenUpdating = True End With End Sub

جمع اقساط للاسماء المتشابهة.xlsm

اضغط على زر النتيجة الأحمر ولاحظ النتيجة تفضل جمع اقساط.xlsm

يعطيك الف عافيه .. جزاك الله الف خير

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

اعتذر منك ، حاولت ولكن محاولاتي لم تنجح للأسف . آملاً أن تجد الحل الذي يحل لك مشكلتك يا صديقي

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Split_names() Dim sp As Variant, j&, lr&, i& Dim WS As Worksheet: Set WS = ActiveSheet With Application .ScreenUpdating = False: .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With lr = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Range("C14:AF" & lr).ClearContents For j = 14 To lr sp = Split(WS.Cells(j, "B").Value2, "*") For i = LBound(sp) To UBound(sp) WS.Cells(j, i + 3).NumberFormat = "@" WS.Cells(j, i + 3).Value = sp(i) Next i Next j With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub فصل كلمات وأرقام v2.xlsb

السطر الأخضر الموجود فيه الأرقام 1 2 3 4 ..... مهم جدا , لو تم تغيير الأرقام ستختلف النتائج اضغط على فصل2 ولاحظ النتيجة تفضل 3صل كلمات وأرقام.xlsb

اخي عند الإلغاء يكون الوقت متاحا مباشرة .. الم تجرب ؟ يعني ان ان السجل الملغى يكون وجوده كعدمه .. ويبقى في السجلات لاحتمال ضرورة مالية 1- عندما تستعرض الحجوزات (القائمة) في تقرير او نموذج عليك استثناء من يحمل اشارة الإلغاء 2- يمكنك استعراض السجلات الملغية فقط ( من اجل الشؤون المالية ) تفضل تم التحويل اتمنى ان يعمل عندك مواعيد دخول وخروج.rar

صدقني اعتذر منك على التأخير .. الملف مفتوح المصدر . Update.accdb

تم عمل استعلام موظف Sub بحث_في_السجل() Dim wsSijel As Worksheet, wsBataka As Worksheet Dim startDate As Date, endDate As Date Dim employeeName As String, movementType As String Dim i As Long, j As Long Dim lastRowSijel As Long, lastRowBataka As Long 'تعيين أوراق العمل Set wsSijel = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة 'قراءة قيم البحث من بطاقة الموظف startDate = wsBataka.Range("A2").Value endDate = wsBataka.Range("B2").Value employeeName = wsBataka.Range("C2").Value movementType = wsBataka.Range("D2").Value 'مسح البيانات القديمة في بطاقة الموظف lastRowBataka = wsBataka.Cells(wsBataka.Rows.Count, "A").End(xlUp).Row If lastRowBataka >= 6 Then wsBataka.Range("A6:F" & lastRowBataka).ClearContents End If 'إيجاد آخر صف في شيت السجل lastRowSijel = wsSijel.Cells(wsSijel.Rows.Count, "A").End(xlUp).Row 'البحث في السجل وعرض البيانات في بطاقة الموظف j = 6 'بداية كتابة البيانات في بطاقة الموظف من الصف 6 For i = 2 To lastRowSijel 'بداية البحث من الصف 2 (تخطي العناوين) If wsSijel.Cells(i, 2).Value = employeeName And _ wsSijel.Cells(i, 4).Value = movementType And _ wsSijel.Cells(i, 5).Value >= startDate And _ wsSijel.Cells(i, 5).Value <= endDate Then 'كتابة البيانات في بطاقة الموظف wsBataka.Cells(j, 1).Value = wsSijel.Cells(i, 1).Value 'العمود الأول wsBataka.Cells(j, 2).Value = wsSijel.Cells(i, 2).Value 'اسم الموظف wsBataka.Cells(j, 3).Value = wsSijel.Cells(i, 5).Value 'العمود الثالث wsBataka.Cells(j, 4).Value = wsSijel.Cells(i, 6).Value 'نوع الحركة wsBataka.Cells(j, 5).Value = wsSijel.Cells(i, 7).Value 'التاريخ wsBataka.Cells(j, 6).Value = wsSijel.Cells(i, 8).Value 'العمود السادس wsBataka.Cells(j, 6).NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود j = j + 1 'زيادة الصف لكتابة البيانات في الصف التالي End If Next i MsgBox "تم البحث وعرض البيانات بنجاح." 'Call حساب_مجموع_الساعات Call جمع_الساعات_والدقائق End Sub Sub جمع_الساعات_والدقائق() Dim wsBataka As Worksheet Dim نطاق_الجمع As Range Dim مجموع_الوقت As Double Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة ' تحديد نطاق الجمع (F6 إلى آخر خلية في العمود F) Set نطاق_الجمع = Range("F6", Cells(Rows.Count, "F").End(xlUp)) ' جمع القيم في النطاق مجموع_الوقت = WorksheetFunction.Sum(نطاق_الجمع) ' وضع النتيجة في الخلية E4 Range("E4").Value = مجموع_الوقت ' تنسيق الخلية E4 Range("E4").NumberFormat = "[h]:mm" ' أو "h:mm" حسب الحاجة End Sub الخروج والعودة - كود.xlsm

هل هذا هو المطلوب Sub حساب_فرق_الساعات1() Dim wsData As Worksheet, wsSummary As Worksheet Dim lastRowData As Long, lastRowSummary As Long Dim i As Long, j As Long Dim employeeName As String, movementType As String, movementDate As Date Dim exitTime As Date, returnTime As Date, timeDifference As Double Dim totalHours As Double, days As Long, remainingHours As Long Dim summaryDict As Object 'استخدام Dictionary لتجميع الساعات حسب الموظف والشهر 'تعيين ورقتي العمل Set wsData = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsSummary = ThisWorkbook.Sheets("احتساب عدد الساعات") 'تغيير اسم الورقة حسب الحاجة 'إيجاد آخر صف في ورقة البيانات lastRowData = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row 'إضافة عناوين الأعمدة في ورقة الملخص wsSummary.Cells(1, "A").Value = "اسم الموظف" wsSummary.Cells(1, "C").Value = "نوع الحركة (زمنية)" wsSummary.Cells(1, "D").Value = "إجمالي عدد الساعات" wsSummary.Cells(1, "F").Value = "عدد الأيام والساعات المتبقية" 'إنشاء Dictionary لتجميع الساعات Set summaryDict = CreateObject("Scripting.Dictionary") 'حساب الفرق بين وقت الخروج ووقت العودة For i = 2 To lastRowData employeeName = wsData.Cells(i, "B").Value movementType = wsData.Cells(i, "D").Value movementDate = wsData.Cells(i, "E").Value exitTime = wsData.Cells(i, "F").Value returnTime = wsData.Cells(i, "G").Value 'تأكد من وجود وقت خروج ووقت عودة If IsDate(exitTime) And IsDate(returnTime) Then timeDifference = returnTime - exitTime wsData.Cells(i, "H").Value = timeDifference wsData.Cells(i, "H").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تجميع الساعات إذا كانت الحركة "زمنية" If movementType = "زمنية" Then Dim key As String key = employeeName ' استخدام اسم الموظف فقط كمفتاح If summaryDict.Exists(key) Then summaryDict(key) = summaryDict(key) + timeDifference Else summaryDict(key) = timeDifference End If End If End If Next i 'كتابة ملخص الساعات في ورقة الملخص j = 2 Dim key1 As Variant For Each key1 In summaryDict.Keys employeeName = key1 ' استخدام المفتاح مباشرةً كاسم الموظف totalHours = summaryDict(key1) 'كتابة البيانات في ورقة الملخص wsSummary.Cells(j, "A").Value = employeeName wsSummary.Cells(j, "C").Value = "زمنية" wsSummary.Cells(j, "D").Value = totalHours wsSummary.Cells(j, "D").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تحويل الساعات إلى أيام وساعات days = Int(totalHours * 24 / 24) remainingHours = (totalHours * 24) Mod 24 wsSummary.Cells(j, "F").Value = days & " يوم " & remainingHours & " ساعة" j = j + 1 Next key1 MsgBox "تم حساب الفرق بين وقت الخروج ووقت العودة وتلخيص الساعات بنجاح." End Sub الخروج والعودة - كود.xlsm

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