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

انظر المرفق يحوي النموذج المطلوب فقط استورده لبرنامجك ..... ثم جرب LEAVE V. 04.rar

شكرا لكم ساعود ان شاء الله ... المشكلة هو مشكلة الوقت فقط ... ليس لدي الوقت لذلك ... لكن ساعود باذن الله تحياتي لكم

هناك الكثير من الأكواد حول هذا الموضوع لكن الكود في هذا الملف يستطيع ان يفصل الاسماء المركبة حتى الاسم الرابع و أكثر مع اضافة تنسيقات تلوينية للنتائج و القدرة على اضافة بعض الأسماء الأولى للاسم المركب (عبد , أبو , سيف , جمال الخ....) Option Explicit Sub split_names() Application.ScreenUpdating = False Dim my_st$, st1, st2 Dim last_col% Dim my_name, i%, k%, Col%, int_col% Dim Lr%: Lr = Cells(Rows.Count, 1).End(3).Row Dim mon_range As Range Dim fin_rg As Range Range("b2").Resize(Lr - 1, 10).Clear Dim arr: arr = _ Array("سيف", "عبد", "أبو", "ابو", "عز", "صدر", "نور") '++++++++++++++++++++++++++++++++++++++ Rem Array تستطيع ان تضيف اي بداية اسم مركب داخل هذا الــ '+++++++++++++++++++++++++++++++++++++ For i = 2 To Lr If Range("a" & i) = vbNullString Then GoTo Next_i my_st = Trim(Range("a" & i)) my_name = Split(Trim(my_st)) Range("b" & i).Resize(1, UBound(my_name) + 1) = my_name Next_i: Next '============================== For i = 2 To Lr last_col = Cells(i, Columns.Count).End(1).Column Set mon_range = Range(Cells(i, 2), Cells(i, last_col)) For k = 1 To last_col - 1 If Not (IsError(Application.Match(mon_range.Cells(k), arr, 0))) Then st1 = mon_range.Cells(k): st2 = mon_range.Cells(k + 1) mon_range.Cells(k).Delete Shift:=xlToLeft mon_range.Cells(k) = st1 & " " & st2 End If Next Next Set fin_rg = Range("a1").CurrentRegion Lr = fin_rg.Rows.Count Col = fin_rg.Columns.Count With fin_rg.Offset(1).Resize(Lr - 1, Col - 1).Offset(, 1) .Borders.LineStyle = 1: .Font.Bold = True .InsertIndent 1: Columns.AutoFit .SpecialCells(2).Interior.ColorIndex = 35 End With Set mon_range = Nothing Set fin_rg = Nothing Application.ScreenUpdating = True '=============================== End Sub الملف مرفق sep_complex_names_New.xlsm

اشكركم احبتي بارك الله لكم وعليكم........... تمام التمام............. اللهم اجعلة في ميزان حسناتكم وزدكم علما ونورا

وعليكم السلام تفضل

أخى الكريم قم بتجربة هذا الشيت لعله يفي بالغرض وهذا ما تعلمناه فى الصرح الشامخ والمنتدى الرائع النموذج1.xlsx

في البداية قمت باضافة حقل نصي غير منظم مخفي ووضعت مصدر البيانات لهذا الحقل =DCount("[ID]";"Mastr Table";"[PO]='" & [PO] & "'") والهدف هو عدد مرات تكرار قيمة الحقل po ثم قمت بعمل تنسيط شرطي للحق po على اساس اذا كانت قيمة الحقل الغير منظم اكبر من 1 يتم تغيير لون وخط الحقل المكرر اما بشان الرسالة فعن طريق If DCount("[po]", "Mastr Table", "[po] = '" & Me!PO & "'") > 0 Then MsgBox "هذة القيمة مكررة", vbCritical, "تنبية" Else End If

شكرا على الرد أ/ عبد اللطيف سلوم ولكن احتاج الى التكرار فى العمل حيث يمكن توريد امر الشراء على عدة فواتير

قمت بضبط الاعدادات كما قال اخواني الأعزاء والقاعده تعمل الان بشكل سليم جزاكم الله كل خير جميعا

جرب الشرح والخطوات التى داخل هذا الرابط http://www.torkymax.com/2010/10/run-time-error-13-type-mismatch.html

أحسنت جزاك الله كل خير

بارك الله فيك وجزاك الله كل خير

جزاك الله كل خير وزادك الله من فضله

بارك الله فيك

أحسنت بارك الله فيك

بارك الله فيك وزادك الله من فضله

ربما هذا مطلوبك ...... K_1.rar

تم اضافة رسالة عند ادخال قيمة مكررة للحقل po حسب طلبك مع قبول التكرار حسب ما رايتة في بيانات الجدول تم اضافة تنسيق شرطي بتغيير لون الحقل للسجلات المكررة المبيعات.rar

أحسنت استاذ سليم عمل ممتاز جعله الله فى ميزان حسناتك

جرب هذا الملف My_date.xlsm

نفس الطريقة اعلاه ، ولكن بتغيير في الوحدة النمطية التالية: Public Function MyMesg(Mesgtxt As String, _ Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _ Optional ByVal Title As String = "Judy", _ Optional ByVal HelpFile As Variant, _ Optional ByVal Context As Variant, _ Optional ByVal AdditionalInfo As String) As VbMsgBoxResult Mesgtxt = Replace(Mesgtxt, "& Strxx", AdditionalInfo) MyMesg = MsgBox(Mesgtxt, Buttons + vbMsgBoxRtlReading + vbMsgBoxRight + vbDefaultButton1, Title) End Function حعفر 1102.الرسائل من داخل V .01.mdb.zip

تفضل الشرح 🙂 . . . جعفر 1101.تجربة تقرير.accdb.zip

أنا لا أرى ان هذه أصلا مشكلة

عاود فتح البرنامج من جديد ، لا توجد مشاكل لدي في فتح النماذج ما دمت دخل باسم المستخدم وكلمة المرور .

معاي شغاله مافيها مشاكله تاكد من من اعدادات الجهاز من لوحة التحكم - التاريخ والمنطقه SA.bmp

عندي شغالة 100% ولم تظهر أي رسالة خطأ

السلام عليكم 🙂 وبعد تحدي ، وصلنا للمطلوب ان شاء الله 🙂 اضفت الحقول البرتقالية لتحسب عدد المرات الموجود فيها الرقم (من او الى) ، ويمكن جعل هذا الحقل مخفي ، الحقول الخضراء هي حقل محسوب في الجدول (موجود سابقا في البرنامج) . وهذا هو التنسيق الشرطي للحقل بالسهم الاحمر: . هذه الوحدة النمطية التي تقوم بالعمل ، Function Update_All() Dim mySQL As String Dim arr_Fields() As Variant Dim New_value As Long Dim Old_value As Long Dim Number_Field As String Dim tbl_Name As String Dim This_Count As Integer Dim Prev_Count As Integer Dim ctrlN As String Dim frmN As String Dim i As Integer Dim j As Integer Dim This_CountF As Integer Dim Prev_CountF As Integer frmN = Screen.ActiveForm.Name ctrlN = Screen.ActiveControl.Name arr_Fields = Array("من رقم الوارد", "الي رقم الوارد", "من رقـم الرمبة", "الي رقـم الرمبة", "من رقم التخليص", "الي رقـم النخليص") New_value = Forms(frmN)(ctrlN) If Len(Forms(frmN)(ctrlN).OldValue & "") <> 0 Then Old_value = Forms(frmN)(ctrlN).OldValue End If tbl_Name = "جدول الرصاص" 'save Form values If Forms(frmN).Dirty Then Forms(frmN).Dirty = False '1 'get the hieghst value of all fields For i = LBound(arr_Fields) To UBound(arr_Fields) ctrlN = arr_Fields(i) Number_Field = ctrlN & "_2" 'New value This_CountF = DCount("*", tbl_Name, "[" & ctrlN & "]=" & New_value) If This_CountF > 0 Then This_Count = This_Count + This_CountF End If 'Old value If Len(Old_value & "") <> 0 Then Prev_CountF = DCount("*", tbl_Name, "[" & ctrlN & "]=" & Old_value) If Prev_CountF > 0 Then Prev_Count = Prev_Count + Prev_CountF End If End If Next i 'save Form values If Forms(frmN).Dirty Then Forms(frmN).Dirty = False '2 'change the values in the Fields For i = LBound(arr_Fields) To UBound(arr_Fields) ctrlN = arr_Fields(i) Number_Field = ctrlN & "_2" 'New value mySQL = "UPDATE [" & tbl_Name & "] SET [" & Number_Field & "] = " & This_Count mySQL = mySQL & " WHERE [" & ctrlN & "]=" & New_value 'Debug.Print i & "N > " & mySQL; "" DoCmd.RunSQL mySQL 'Old value If Len(Old_value & "") <> 0 Then mySQL = "UPDATE [" & tbl_Name & "] SET [" & Number_Field & "] = " & Prev_Count mySQL = mySQL & " WHERE [" & ctrlN & "]=" & Old_value 'Debug.Print i & "O > " & mySQL DoCmd.RunSQL mySQL End If 'force the field in the Form to take the new value Forms(frmN)(Number_Field).Requery Next i End Function . ويتم مناداتها من حدث بعد التحديث لكل حقل ، مثلا : Private Sub الي__رقـم_الرمبة_AfterUpdate() Call Update_All End Sub . اسماء الحقول صارت مبرمجة في: الجدول ، النموذج ، الوحدة النمطية ، والتنسيق الشرطي ، لذا ، اذا فكرت بتغيير اسم الحقل في الجدول (او اضافة حقول جديدة) ، فيجب مراعاة تعديل الكائنات التي اشرت اليها اعلاه 🙂 جعفر 1095.مثال.accdb.zip