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

وعليكم السلام اتفضل اخى @ازهر عبد العزيز ان شاء الله يكون ما تريد Private Sub idx_NotInList(NewData As String, Response As Integer) Dim strSql As String, x As Integer x = MsgBox("هذا الاسم غير موجود .. هل ترغب في إضافته؟", vbYesNo + vbDefaultButton1) If x = vbYes Then strSql = "Insert Into tbx (x1) values ('" & NewData & "')" CurrentDb.Execute strSql Response = acDataErrAdded Else Response = acDataErrContinue End If End Sub بالتوفيق XY.accdb

اخي الكريم منكم وبكم نتعلم الابداع

بالتاكيد لكني لم استطيع اظهار رسالة التحذير في حلي XY.accdb

بعد إذن جميع الأخوة المشاركين هذا جهدي المتواضع لإثراء الموضوع يمكن اختصار الإجراء لهذا الكود Sub TEST() Dim Sh As Worksheet, LR As Long, Cel As Range Dim Texte1 As String For Each Sh In Worksheets(Array("DATA")) LR = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row Texte1 = Ar_WriteDownNumber(Cells(LR, "Q") + (Cells(LR, "p") / 100), "جنيها", "قرشا", 100) Sh.Cells(LR + 2, "C").Value = "فقط " & Texte1 ''' هنا حدد اين تريد يظهرالتفقيط ActiveWindow.SelectedSheets.PrintOut Copies:=1 Sh.Range(Sh.Cells(LR + 1, "A"), Sh.Cells(LR + 12, "C")).ClearContents Next Sh End Sub

جرب هذا الملف 1- القائمة المنسدلة في الخلية j2 ديناميكية اي انها تستحيب لاي تغيير في الداتا مع عدم تكرار الاسماء Option Explicit '+++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() DATA_VAL End Sub '++++++++++++++++++++++++++++++ Sub DATA_VAL() Dim NT As Worksheet Dim SA As Worksheet Dim RON%, ROS%, i% Set NT = Sheets("NEW_TABLE") Set SA = Sheets("Salary") Dim Dic As Object ROS = SA.Cells(Rows.Count, 1).End(3).Row If ROS < 4 Then Exit Sub Set Dic = CreateObject("Scripting.Dictionary") For i = 4 To ROS If SA.Cells(i, 6) <> "" Then Dic(SA.Cells(i, 6).Value) = "" End If Next If Dic.Count Then With NT.Cells(2, "j").Validation .Delete .Add 3, Formula1:=Join(Dic.keys, ",") End With NT.Cells(2, "j").Value = Dic.keys()(0) End If End Sub '++++++++++++++++++++++++++++++++ Sub Fil_Data() Dim Adr1%, Adr2%, X%, m%, k%, ROS% Dim wat, Ro% Dim Find_rg As Range Dim Band As Range Dim Bol As Boolean Dim NT As Worksheet Dim SA As Worksheet Set NT = Sheets("NEW_TABLE") Set SA = Sheets("Salary") NT.Range("A2").CurrentRegion.Offset(1).Clear If NT.Range("J2") = "" Then Exit Sub wat = NT.Range("J2") m = 3 ROS = SA.Cells(Rows.Count, 6).End(3).Row '+++++++++++++++++++++++++++++++++++++++++ With SA.Range("F3:F" & ROS) Set Find_rg = .Find(What:=wat, LookIn:=xlValues, lookat:=1) If Not Find_rg Is Nothing Then Adr1 = Find_rg.Row: Adr2 = Adr1 Do NT.Range("A" & m).Resize(, 7).Value = _ SA.Range("A" & Adr2).Resize(, 7).Value m = m + 1 Set Find_rg = .FindNext(Find_rg) Adr2 = Find_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If End With If m > 3 Then X = 3 With SA.Range("F3:F" & ROS) Set Find_rg = .Find(What:=NT.Range("F3"), LookIn:=xlValues, lookat:=1) If Not Find_rg Is Nothing Then Adr1 = Find_rg.Row: Adr2 = Adr1 Do Bol = False For k = 8 To 67 If SA.Cells(Adr2, k) <> "" Then Bol = True Exit For End If Next k If Bol Then NT.Cells(X, "H") = SA.Cells(3, k) X = X + 1 End If Set Find_rg = .FindNext(Find_rg) Adr2 = Find_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If End With With NT.Range("A3:H" & m - 1) .Font.Size = 14 .Font.Bold = True .Borders.LineStyle = 1 .InsertIndent 1 .Interior.ColorIndex = 35 End With End If End Sub النلف مرفق RAWATEB.xlsm

تفضل vlook.xlsm

جرب هذ الملف (تكتب الارقام في العامود B) SABIL.xlsx

جرب هذا الكود ... Like "*" & [Forms]![SearchF]![k].[Text] & "*"

وهذه طريقة اخرى مشاركة مع استاذي الفاضل @kha9009lid وهي عن طريق انشاء جدول وفرز عمليات كل الموظفين من الجدول المعطى ثم عرضها عن طريق استعلام تجميع ميزة هذه الطريقة انها لا تتقيد بعدد الموظفين الذين يشتركون في العملية ( يعنى ممكن مشاركة العملية عدد لا حصر له من الموظفي ... اثنين أو 100 ) وهذا هو الكود المستخدم DoCmd.SetWarnings False DoCmd.RunSQL "DELETE * FROM Table3" DoCmd.SetWarnings True Dim rstS As DAO.Recordset Dim rstD As DAO.Recordset Dim x() As String Dim i As Long Set rstS = CurrentDb.OpenRecordset("Select * From [Table1]") Set rstD = CurrentDb.OpenRecordset("Select * From Table3") DoCmd.Hourglass True Do While Not rstS.EOF x = Split(rstS![الاسم], "-") For i = LBound(x) To UBound(x) rstD.AddNew rstD!عدد_العمليات = rstS![عدد_العمليات] rstD!الاسم = Trim(x(i)) rstD.Update Next i rstS.MoveNext Loop rstS.Close: Set rstS = Nothing rstD.Close: Set rstD = Nothing DoCmd.Hourglass False Me.Requery Exit Sub op.accdb

مشاركة متواضعة مني عن طريق عدد 2 استعلام الاستعلام الاول نقوم بتقسيم حقل الاسم الى عمودين باستخدام دالة عمنا العود @ابوخليل جزاه الله خير Public Function qsplit(NName As String, i As Integer) On Error Resume Next qsplit = Split(NName, "-")(i) End Function الاستعلام الثاني استعلام توحيدي ومصدره الاستعلام الاول لغرض توحيد حقلي الاسم ثم نضع شرط في الاستعلام لحذف الصفوف الخالية والنتيجة في المرفق ملاحظة يمكن الاستغناء عن الاستعلام الاول وعمل استعلام التوحيد مباشرة من الجدول مع استخدام الدالة والمعايير ولكن سوف يكون صعب على غير المختصين هذا الحل البسيط يعتمد على فهمي للموضوع وربما لم افهم المطلوب بشكل صحيح op.accdb

هل هناك جدول اخر لاسماء الموظفين غير هذا الجدول ؟؟؟؟ ممكن تزودنا به

السلام عليكم تم تعديل آلية الترقيات السابقة ، حيث تم اضافة شرط لعدد نقاط الاعجاب لتنفيذ الترقية الالية ، كما هو مبين أدناه الدرجة الحالية المشاركات نقاط االاعجاب عضو جديد 01 50 - 02 الأعضاء 100 10 03 عضو مميز 500 50 04 عضو فضي 1000 100 05 عضو ذهبي 1000 500 06عضو ماسي 1000 1000 عند وصول نقاط الاعجاب الي 1000 للعضو الماسي سيتم الترقية الي مجموعة أعضاء الشرف و التي تضم أيضا المكرمين من ممن لهم مساهمات خارج الموقع و ستتغير الدرجة بالترقية للأعلى بعد اول مشاركة للعضو ، و لن يتم تخفيض أي درجات حالية. و تبقي مجموعات الخبراء و فريق الموقع و فريق الموقع السابق و أعضاء الشرف دون تعديل كما سيتم قريباً بإذن الله استحداث درجة خبير مخضرم لتكون الترقية التالية لدرجة خبير و سيتم الاعلان قريبا عن موعد تطبيقها و آلية التطبيق

تفضل هذا التعديل DATA20009.zip

فقط امسح الخلية J2 واضغط الزر

جزاكم الله خيرا اخووانى واساتذتى 💐 ومشاركه مع اخوانى واساتذتى حاجه ع قد حالى وتاكيدا على وجود جدول خاص بالاسماء قمت بانشاء جدول خاص بالاسماء ولبيان السبب انظر الاستعلام رقم 1 هتلاقى عندك 4 اسماء والاستعلام الثانى 5 SELECT tblNames.Sname, DSum("[عدد العمليات]","Table1","[الاسم] Like '*" & [Sname] & "*'") AS Expr1 FROM tblNames; دى صوره الاستعلام الاول ودى صورة الاستعلام الثانى جزاكم الله خيرا اخوانى واساتذتى بالتوفيق op_1.accdb

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

السلام عليكم .. إخوتي هل يمكن النسخ بواسطة الماوس من النموذج والتقرير بدون استخدام اختصار c+ctrl ؟ بحثت ومع الأسف لم أعثر على نتيجة !!

وعليكم السلام تفضل محاولة مني Lock shift1.accdb

لا ادري اذا كان هذا ما تريده جرب هذا الملف جلب البيانات على اساس راس الجدول1.xlsm

تفضل New Microsoft Excel Worksheet.xlsx

شكرا أخي حسن لاعدمناك

ارفع ملف به ما تقول في مشاركة منفصلة احسن

ممكن تسرح اكثر لم افهم شيء مما طلبت

عليكم السلام، أعد ترتيب الحقول بحيث تكون بشكل عمودي

لازم تسحب اول خلية لاخر صف تريد العمل عليه ..

مشكور اخي ولكن لأجل أن أتعلم .. ممكن تشرحلي مصدر الارقام بالصورة

تكتب البيانات في النطاق I1:j50 الغامودين I و J يمكن اخفائها عن غيون الفضوليين ثم تختار في العامود B الرقم الذي تريد

طيب غير الفانكشن الى عندك بهذا الكود .... On Error GoTo Error_Handler Dim MyFile As String Dim db As Database Dim sSQL As String Set db = CurrentDb() If Right(strPath, 1) <> "" Then strPath = strPath & "" If strFilter = "" Then strFilter = "*" MyFile = Dir$(strPath & "*." & strFilter) Do While MyFile <> "" myfile1 = Left([MyFile], InStrRev([MyFile], ".") - 1) sSQL = "INSERT INTO [BASIC_DATE] (crn) VALUES(""" & myfile1 & """)" db.Execute sSQL, dbFailOnError MyFile = Dir$ Loop Error_Handler_Exit: On Error Resume Next Set db = Nothing Exit Function Error_Handler: MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: ImportDirListing" & vbCrLf & _ "Error Description: " & Err.Description, vbCritical, _ "An Error has Occured!" Resume Error_Handler_Exit

منتهى الابداع كعادتك @kanory

هل هذا ماتريد ... ناقل.mdb

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

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

بعد اذن الاستاذ نزار هذا الكود Option Explicit Sub Fil_Ijasat() Dim Dic As Object, KY Dim I%, lr%, m%, K% Dim txt Dim EE#, FF#, HH#, JJ#, GG#, II#, KK# Dim Source_Sheet As Worksheet Dim Target_Sheet As Worksheet Dim Cur_Value Set Source_Sheet = Sheets("Sheet1") Set Target_Sheet = Sheets("Sheet2") Set Dic = CreateObject("Scripting.Dictionary") lr = Source_Sheet.Cells(Rows.Count, 2).End(3).Row Target_Sheet.Range("a3:k100").ClearContents If lr < 4 Then Exit Sub For I = 4 To lr txt = Source_Sheet.Cells(I, 2).Resize(, 3) txt = Application.Transpose(txt) txt = Application.Transpose(txt) txt = Join(txt, "*") Dic(txt) = Dic(txt) + Val(Source_Sheet.Cells(I, 7)) Next I If Dic.Count Then m = 3 For Each KY In Dic Target_Sheet.Cells(m, 1) = m - 2 Target_Sheet.Cells(m, 2).Resize(, 3).Value = _ Split(KY, "*") m = m + 1 Next KY End If Set Dic = Nothing If m > 3 Then For I = 3 To m - 1 For K = 4 To lr If Target_Sheet.Cells(I, 2) = Source_Sheet.Cells(K, 2) Then Cur_Value = Val(Source_Sheet.Cells(K, 7)) Select Case Trim(Source_Sheet.Cells(K, 8)) Case "اعتيادي": EE = EE + Cur_Value Case "عارضة": FF = FF + Cur_Value Case "اذن": HH = HH + Cur_Value Case "تناوب": JJ = JJ + Cur_Value Case "انقطاع": GG = GG + Cur_Value Case "راحة": II = II + Cur_Value Case "مرضي": KK = KK + Cur_Value End Select End If Next K With Target_Sheet.Cells(I, 5) .Value = IIf(EE = 0, "", EE) .Offset(, 1) = IIf(FF = 0, "", FF) .Offset(, 2) = IIf(GG = 0, "", GG) .Offset(, 3) = IIf(HH = 0, "", HH) .Offset(, 4) = IIf(II = 0, "", II) .Offset(, 5) = IIf(JJ = 0, "", JJ) .Offset(, 6) = IIf(KK = 0, "", KK) End With EE = 0: FF = 0: GG = 0: HH = 0 II = 0: JJ = 0: KK = 0 Next I End If End Sub الملف مرفق Ijasat.xlsm

وعليكم السلام تم عمل المطلوب حسب الصورة ادناه وتمت اضافة طريقة اخرى اسفل الجدول عن طريق القوائم المنسدلة جرب واي استفسار اعلمني تجميع ب sumif.xls

عليكم السلام، اخوية شوف هذا الشرح

وهل من المفروض على من سيقوم بالمساعدة ان ينشأ لك ملفاً بما تريد؟ ام عليك رفع الملف بنفسك على كل حال اليك هذا النموذج يحتوي على 2 ماكرو واحد للقوائم المنسدلة والاحر لادراج الاسماء 10 : 10 الماكرو ديناميكي (اي انه يحصي كل الاسماء مهما كان عددها) (كل مجموعة مرتية ابجدياُ) Option Explicit Sub Get_data_val() Const t = 10 Dim obj As Object Dim lr%, i%, m%, k%, Cnt% Dim arr Dim My_rg As Range If ActiveSheet.Name <> "Sheet1" Then Exit Sub k = 3 lr = Cells(Rows.Count, 1).End(3).Row Set obj = CreateObject("System.Collections.Arraylist") For i = 2 To lr Step t Set My_rg = Cells(i, 1).Resize(t) Cnt = Application.CountA(My_rg) Set My_rg = My_rg.Cells(1, 1).Resize(Cnt) Do Until m = Cnt obj.Add My_rg.Cells(m + 1, 1).Value m = m + 1 Loop If obj.Count Then obj.Sort With Cells(2, k).Validation .Delete .Add 3, Formula1:=Join(obj.Toarray, ",") Cells(2, k) = obj(0) End With End If k = k + 1: m = 0 obj.Clear Next i End Sub '++++++++++++++++++++++++++++++++++ Sub Get_By_10() Const t = 10 Dim obj As Object Dim lr%, i%, m%, k%, Cnt% Dim My_rg As Range If ActiveSheet.Name <> "Sheet1" Then Exit Sub k = 3 lr = Cells(Rows.Count, 1).End(3).Row Set obj = CreateObject("System.Collections.Arraylist") Cells(5, 3).CurrentRegion.Offset(1).ClearContents For i = 2 To lr Step t Set My_rg = Cells(i, 1).Resize(t) Cnt = Application.CountA(My_rg) Set My_rg = My_rg.Cells(1, 1).Resize(Cnt) Do Until m = Cnt obj.Add My_rg.Cells(m + 1, 1).Value m = m + 1 Loop If obj.Count Then obj.Sort Cells(5, k).Resize(obj.Count) = _ Application.Transpose(obj.Toarray) End If k = k + 1: m = 0 obj.Clear Next i End Sub الملف مرفق Kaissi.xlsm

بارك الله لك أخي عماد بالفعل ما تقوله صحيح وربما اشتبه علي الأمر حيث توجد هذه الميزة في vb و vb.net ولكن بالتحقق من نوع بيانات المتغير c1 من خلال كتابة الدالة typename(c1) يظهر لنا أنه بالفعل تم الإعلان عن المتغير وحجز مكان في الذاكرة له ولكن يبقى نوع بياناته فارغاً empty فإذا تم تعيين قيمة له وكانت هذه القيمة تاريخ يظهر لنا أن نوع بيانات هذا المتغير date .............. فالفرق الجوهري بين المتغير الأول والثالث في السطر هو: أن المتغير الأول والثاني يمكن تغيير نوع بياناتهم حسب القيمة التي يتم تعيينها لهم أما المتغير الثالث يثبت على نوع البيانات التي تم تعريفه بها وممكن أن يرى أحدنا هذه بأنها ميزة في تغير نوع بيانات المتغير. .......... أنا شخصياً أعتمد على الطريقة الثانية وهي الأصح dim c1 as date,c2 as date,c3 as date وفي الأخير أتمنى أن نكون قد استفدنا من هذا الجزء وبانتظار ملاحظتكم بخصوص الهديتين