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

السلام عليكم ورحمة الله وبركاته تحياتي لاستاذنا ومعلمنا الفاضل أبوعيد تحياتي للاستاذ الفاضل MAHMOUD ELWY من خلال الاطلاع على الملفات التى ارفقتها لتوضيح الطلب وخصوصا ملف السائق احمد اعتفد ان هناك خطا في فيمة العهدة والمصروفات فهي مكررة وهذا ما اشار اليه استاذنا ابو عيد بعدم لتجاوب السريع من الأعضاء على مشاركتك لوجود الغموض فحسب الصورة العهدة 20000 ولبس 40000 والمصروف 5500 بدل 11000 ويتبقى مع السائق 14500 وليس 29000 هذا خسب قهمى وان كنت مخطئا فارجو توضيخ كيف اتت هذه الارقام وبتاء على فهمى السابق اليك ملفان اخدهما يتشئ ملقات جديدة لكل سائق والاخر في نفس الملف واعتقد لا يوثر ولا يسبب ثقلا للملف كل سائق ملف جديد.xlsbجميع السائقين في نفس الملف.xlsb

وعليكم السلام ورحمة الله وبركانه اليك التصحيج Sub Filter_Class2() Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD") Dim D1 As Object, D2 As Object, D3 As Object, D4 As Object Dim I As Long, x As Long, Y As Long, m As Long, z As Long Dim Réf As Variant, ky As Variant, Rng As String Set D1 = CreateObject("Scripting.Dictionary") Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") Set D4 = CreateObject("Scripting.Dictionary") x = 0: Y = 0: m = 0: z = 0 With WSdest Application.ScreenUpdating = False .Range("M4:V32,X4:AG32,AI4:AR32,AT4:BC32").ClearContents I = 7 Do While I <= .Rows.Count If .Cells(I, 2) <> "" Then Rng = Left(Trim(.Cells(I, 2).Value), 1) Réf = Application.Transpose(.Cells(I, 2).Resize(, 13).Value) Réf = Application.Transpose(Réf) Select Case Rng Case "4" D4(z) = Join(Réf, "*") z = z + 1 Case "3" D3(Y) = Join(Réf, "*") Y = Y + 1 Case "2" D2(x) = Join(Réf, "*") x = x + 1 Case "1" D1(m) = Join(Réf, "*") m = m + 1 End Select I = I + 1 Else Exit Do End If Loop m = 4 If D4.Count > 0 Then For Each ky In D4.Keys .Cells(m, "M").Resize(, 13).Value = Split(D4(ky), "*") m = m + 1 Next ky End If m = 4 If D3.Count > 0 Then For Each ky In D3.Keys .Cells(m, "X").Resize(, 13).Value = Split(D3(ky), "*") m = m + 1 Next ky End If m = 4 If D2.Count > 0 Then For Each ky In D2.Keys .Cells(m, "AI").Resize(, 13).Value = Split(D2(ky), "*") m = m + 1 Next ky End If m = 4 If D1.Count > 0 Then For Each ky In D1.Keys .Cells(m, "AT").Resize(, 13).Value = Split(D1(ky), "*") m = m + 1 Next ky End If .Range("M4").CurrentRegion.Value = .Range("M4").CurrentRegion.Value .Range("X4").CurrentRegion.Value = .Range("X4").CurrentRegion.Value .Range("AI4").CurrentRegion.Value = .Range("AI4").CurrentRegion.Value .Range("AT4").CurrentRegion.Value = .Range("AT4").CurrentRegion.Value Application.ScreenUpdating = True End With End Sub 1تعداد.xlsm

السلام عليكم طبعا الفكره قديمه واحد الاخوه كان عامل مثلها ولاكن انا عدلت عليها بطريقه تكون سهلة وبسيطة وبدون اي شرح اليكم الببرنامج رسائل.zip

نمط تفاعلي للواجهة ويوجد انماط اخرى 😇 تعديل على مرفق @Moosak 1- طريقة الاستخدام الواجهة اذا كنت ترغب بتعديل بقائمة الجنب يعمل مستمر مع دالة عند ضغط لاي زر في واجهة الاخرى الرئيسية او حدث ايقاف التفعيل ثم التفعيل فقط الدالة والمرفق والشرح بموضوع @Moosak اسفل الفيديو ================================================( بسيط يمكن اضافة قائمة لاختيار انماط الحقول بدل من المسار الدالة : Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _ (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _ (ByVal hwnd As LongPtr, ByVal nIndex As Long, _ ByVal dwNewLong As LongPtr) As LongPtr #Else Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long #End If Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_COMPOSITED = &H2000000 '==== دالة عامة تحدد النموذج بالاسم وتفعّل/تُلغى الـ DoubleBuffering ==== Public Sub ToggleFormDoubleBuffering(FormName As String, EnableIt As Boolean) Dim hWndForm As LongPtr ' تأكد أن النموذج مفتوح If Not CurrentProject.AllForms(FormName).IsLoaded Then MsgBox "النموذج " & FormName & " غير مفتوح.", vbExclamation Exit Sub End If ' اجلب الـ hWnd hWndForm = Forms(FormName).hwnd #If VBA7 Then Dim style As LongPtr style = GetWindowLongPtr(hWndForm, GWL_EXSTYLE) If EnableIt Then style = style Or WS_EX_COMPOSITED Else style = (style And Not WS_EX_COMPOSITED) End If SetWindowLongPtr hWndForm, GWL_EXSTYLE, style #Else Dim style32 As Long style32 = GetWindowLong(hWndForm, GWL_EXSTYLE) If EnableIt Then style32 = style32 Or WS_EX_COMPOSITED Else style32 = (style32 And Not WS_EX_COMPOSITED) End If SetWindowLong hWndForm, GWL_EXSTYLE, style32 #End If End Sub 'تفعيل DoubleBuffering على نموذج معين 'Call ToggleFormDoubleBuffering("اسم_النموذج", True) 'إلغاء DoubleBuffering على نموذج معين 'Call ToggleFormDoubleBuffering("اسم_النموذج", False) Public Sub ToggleFormOrSubformDoubleBuffering(FormName As String, Optional SubformControlName As String = "", Optional EnableIt As Boolean = True) Dim hWndForm As LongPtr If Not CurrentProject.AllForms(FormName).IsLoaded Then MsgBox "النموذج " & FormName & " غير مفتوح.", vbExclamation Exit Sub End If If SubformControlName <> "" Then hWndForm = Forms(FormName).Controls(SubformControlName).Form.hwnd Else hWndForm = Forms(FormName).hwnd End If ' تطبيق النمط #If VBA7 Then Dim style As LongPtr style = GetWindowLongPtr(hWndForm, GWL_EXSTYLE) If EnableIt Then style = style Or WS_EX_COMPOSITED Else style = (style And Not WS_EX_COMPOSITED) End If SetWindowLongPtr hWndForm, GWL_EXSTYLE, style #Else Dim style32 As Long style32 = GetWindowLong(hWndForm, GWL_EXSTYLE) If EnableIt Then style32 = style32 Or WS_EX_COMPOSITED Else style32 = (style32 And Not WS_EX_COMPOSITED) End If SetWindowLong hWndForm, GWL_EXSTYLE, style32 #End If End Sub 'على نموذج رئيسى 'Call ToggleFormOrSubformDoubleBuffering("frmMain", , True) 'على نموذج فرعى داخل نموذج رئيسى 'Call ToggleFormOrSubformDoubleBuffering("frmMain", "subMyForm", True) تحميل المرفق https://www.mediafire.com/file/1qo54r19srcfear/API_WS_EX_COMPOSITED.rar/file

تحديــــــــــــث بسيط 1- تسريع التنقل عند القائمة الجانبية عند كود استاذ @Moosak 😇 تم الغاء الكود ' Me.Repaint 2- تفعيل الوقت مع القائمة جانبية مع بعض التصحيحات وتكبير ============================( المرفق اسفل الفيديو تحميل المرفق https://www.mediafire.com/file/ruzomjy5j9pdhv2/V1_API_WS_EX_COMPOSITED.rar/file

انا استخدم هذه انواع .. باركود.rar

سبحان الله، الموضوع كان نشط وبمجرد شاركت أنا فيه نام وخمد!! نفس الفكرة ولكن من خلال زر ارقام النتائج عربي_05.xlsm