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

يمكنك إظافة السطور التالية لتحديد التنسيق الدي يناسبك Dim ColArr As Variant, col As Variant ColArr = Array("H", "I", "J", "K") For Each col In ColArr With dest.Range(col & "5:" & col & dest.Rows.Count) .NumberFormat = "dd/mm/yyyy" End With Next col العقود v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant: Set crWS = Sheets("العقود") arr = Array("العقود", "") ' في حالة وجود أوراق أخرى يجب الإحتفاظ بها قم بإظافتها هنا lastRow = crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row If lastRow < 5 Then: Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then: f.Delete End If Next f OnRng = crWS.Range("J4:J" & lastRow).Value For i = 1 To UBound(OnRng, 1) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") Next i crWS.Range("J4:J" & lastRow).Value = OnRng For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)): n = Month(sDate): x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, "J").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter .Range("J5:J" & lr).NumberFormat = "dd/mm/yyyy" End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function العقود v2.xlsb

بارك الله فيكما وأكثر الله من أمثالكم وجعله في ميزان حسناتكما وزادكما الله من علمه

حسنا , يوجد مشكلة لنفترض أن الشركة ASD تكررت ثلاث مرات وكل مرة يوجد لها FROM و Till يختلف فعند إحضار البيانات أيهما سيتم جلبه إذا كان FROM و Till لكل مرة يختلف عن الآخرى ؟

الملف بدعم الإصدار 32 بت . Main.accdb

شكرا لك ا. محمود بارك الله فيك

لقد ارفقت لك الملف

كل الشكر والتقدير والاحترام لك ولجميع من ساهم في طرح الحلول .. من وجهة نظري الشخصية المتواضعة ؛- 1. بناء على الحلول فإنه لا فائدة من إبقاء الحقل الخاص بالفلس بوحدة "Double" !! 2. جرب مثلاً ان تكون إحدى القيم 0,05 على سبيل المثال لا الحصر ، كم ستكون النتيجة !!! 3. أعتقد - واعتقادي غير ملزم - بأن الصحيح والمنطقي هو الإهتمام بمصدر بيانات الحقل ، فهو كفيل بتحقيق أهدافك دون الحاجة لعناء إجبار الحقل على تحديث قيمه من خلال استعلام. ولكن بما أنك أوضحت أن المصدر هو سجلات موجودة مسبقاً ، فقد تسقط لديك هذه النقطة. شكراً لكم ، والحمد لله انك وجدت الحل 😇🤗 .

أشكر مرورك العطر ،، طبعاً بلا شك سيتم الدعم للإصدار 32 يا صديقي 🤗

إذا الكسر مقتطع من رقم كسري مثلا 6.5 فهذا يعني ستة دينار ونصف الدينار وبما أن الدينار يساوي 1000 فلس فنصفها يعني 500 فلسا وليس خمسة فلوس. ثم أن جمع فلس فلوس وليس أفلاس عموما وجود الفاصلة العشرية في الفلوس شيء غريب. على كل كان الحل عندك وبأكثر من خيار ولكن يبدو أنك لم "تهضمه". يفضل أن لا تتجاهل أي واحد ممن سعى لخدمتك حتى وإن لم تجد في محاولته مبتغاك، كلامي للكل وليس لي. جرب أن تشغل الاستعلام أكثر من مرة وأعد مراجعة النتائج. موفق.

وعليكم السلام تفضل Summary1.xlsx

ماشاء الله ا. محمد هشام تسلم ايديك الكود يعمل بكفائه ولكن لم يقم بنسخ نفس التنسق هل ممكن تعديل الكود ليقوم بنسخ نفس التنسيق ربنا يجزيك كل خير ويزيديك من فضله وعلمه

احسنت استاذنا الغالى / محمد هشام يوجد ملحوظة بسيطة وهى عند تقسيم الموظفين بناء على التاريخ يظهر تنسيق بيانات التاريخ ارقام فى اعمدة معينة وهذا الكود المعدل البسيط بعد اذن استاذنا Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant Dim dateCol As String ' لتخزين حرف عمود التاريخ Set crWS = Sheets("العقود") dateCol = "J" ' حدد حرف عمود التاريخ هنا arr = Array("العقود", "") lastRow = crWS.Cells(crWS.Rows.Count, dateCol).End(xlUp).Row If lastRow < 5 Then Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False .Calculation = xlCalculationManual ' تعطيل العمليات الحسابية للتسريع End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then f.Delete End If Next f OnRng = crWS.Range(dateCol & "4:" & dateCol & lastRow).Value ' تصحيح تحويل التاريخ وتنسيقه *قبل* الكتابة إلى الورقة For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then ' التعامل مع تنسيقات التاريخ المختلفة (بما في ذلك مع وجود نقطتين) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)) n = Month(sDate) x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value ' كتابة البيانات dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data ' تعيين تنسيق التاريخ *مباشرة* بعد كتابة التاريخ dest.Cells(Irow, dateCol).NumberFormat = "dd/mm/yyyy" ' تنسيق عمود التاريخ المحدد ' تنسيق الأعمدة H و I و K dest.Cells(Irow, "H").NumberFormat = "dd/mm/yyyy" dest.Cells(Irow, "I").NumberFormat = "dd/mm/yyyy" dest.Cells(Irow, "K").NumberFormat = "dd/mm/yyyy" With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, dateCol).End(xlUp).Row) ' استخدام dateCol هنا أيضًا .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter ' لا حاجة لتعيين تنسيق الرقم للعمود بأكمله هنا، فقد تم بالفعل End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True .Calculation = xlCalculationAutomatic ' إعادة تمكين العمليات الحسابية End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function العقود.xlsm

مشكور على التحديثات الأخيرة وفقنا الله وإياك ورحم والدينا أجمعين .. وياليت التحديث ليشمل النواة 32 بت مع الشكر ..

تفضل أخي الكريم TEST1.accdb

محاولتي بخيارين للفلوس وحقل نسبة TEST1_02.accdb

الآن التحديث الجديد يدعم صيغ آكسيس جميعها ، وخصوصاً لمن سألني عن Accde . لا تغيير على الملف الرئيسي في المرفق التالي . تم تحديث واجهة التحديث كما في الصورة التالية :- 3. تحسين عملية التحميل . Main.accdb

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل هذه أحد الطرق الممكنة : 2 Events.accdb