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

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

السلام عليكم و رحمة الله استخدم الكود التالى Sub GetInv() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, CuName As String Dim Date1 As Date, Date2 As Date Dim i As Long, p As Long Set ws = Sheets("فاتورة تاريخ") CuName = ws.Range("C1").Text If CuName = Empty Then Exit Sub Set Sh = Sheets(CuName) Date1 = ws.Range("C2") Date2 = ws.Range("C3") ws.Range("A10").CurrentRegion.Offset(1, 0).ClearContents LR = Sh.Range("M" & Rows.Count).End(3).Row p = 9 i = 10 Do While i <= LR If Sh.Cells(i, 13) >= Date1 And Sh.Cells(i, 13) <= Date2 Then p = p + 1 Sh.Cells(i, 1).Resize(, 13).Copy ws.Range("A" & p).PasteSpecial xlPasteValues ws.Range("A" & p) = p - 9 End If i = i + 1 Loop Application.CutCopyMode = False End Sub

السلام عليكم ورحمة الله وبركاته تطبيق ادخال بيانات احترافي مميز شاشة رئيسية وشاشة ادخال وشاشة اضافة مستخدمين متعدد الصلاحيات اقفال التطبيق عند ادخال بيانات دخول خاطئة وايقافة لمدة دقيقتين شاشات مميزة احترافي يعمل على عدة اصدارات اتمنى ينال اعجابكم وبنتظار تعليقاتكم اسم المستخدم a كلمة السر 1 كلمة السر لاضافة او التعديل 1 وشكرا لكم للتحميل من هنااااا تم تحديث الرابط هنا

سؤال جميل استاذ امير .. الموضوع يحتاج لموديول نمرر به العمر والوزن عن طريق استعلام للمقارنة مع العمر والوزن للشخص مجرد فكرة راودتني ..بس مو هسة ...لان قفلت 😄

السلام عليكم . استاذنا الخبير lionheart اشار الى الحل في الردود السابقة وكان حله قبل ارفاق ملفك حيت كانت الخلية K5 ولكن بعد ارفاق الملف تغيرت الخلية واصبحت K1 حسب الكود في الملف المرفق يجب كتابة رقم في الخلية K1 في صفحة sheet RM3 وقمت بتجربة الامر واختفى الخطأ تحياتي اليك والى معلمنا الفاضل lionheart

Try this code Private Sub ComboBox1_Change() Dim t As Double, i As Long With Me.ListBox1 For i = 0 To .ListCount - 1 If .List(i, 1) = ComboBox1.Value Then t = t + Val(.List(i, 3)) End If Next i End With Me.TextBox10.Value = t End Sub

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

ياأخي كود المهندس قسم يعمل جيداً حسب معطياتك . انت من ادرجت حقل التاريخ ولم تدرج أي شيء عن الموردين راجع مرفقك وأرسل المرفق الصح .

اقتراح: تحديد لجنة للتحكيم واالجنة هي التي تحدد برنامج واحد للكل للعمل عليه ( اسم البرنامج موحد لكل من سيشترك - الهدف من البرنامج - الجهه المستهدفة -...........)

عليكم السلام وجدت هذا الكود وقمت بالتعديل عليه بحيث يظهر الاقراص الخارجية في قائمة وفي القائمة الاخرى يظهر جميع الأقراص وتم تطبيقه على المرفق ادناه Dim vl As Scripting.FileSystemObject Dim Drv As Scripting.Drive Set vl = New Scripting.FileSystemObject For Each Drv In vl.Drives coDesks.AddItem Drv.DriveLetter If Drv.DriveType = Removable Then coDesks2.AddItem Drv.DriveLetter End If Next Drv عند نقلك الكود الى برنامجك لا تنسى اضافة المكتبة الخاصة ... اطلع عليها في المثال deskDb.rar

التحية والتقدير للاح الاستاذ Eng.Qassim تم وضع كود استاذنا الفاضل وإضافة نقل المحصص الى حقل البحث اضغط على المخصص دبل كلك تم اطبع mus1.rar

في حدث بعد التحديث استخدم الكود التالي.. If DCount("*", "Table1", "[datea]=" & "#" & Me.cbo1 & "#") = 0 Then MsgBox "التاريخ غير موجود!" End If

انا عيوني زغللت وانا اكتب الكود ...طبعا لم اجربه لحد الان وربما فيه خطأ...لكني احب مشاركة بقية الاخوة للتصحيح عملت موديول لتمرير العمر والطول ...عسى احد الاخوة يساعدنا ... لاني بجد قفلت ...يعني نعست 🥱 Function GetIdealWeight(age As Integer, height As Integer) As Double Select Case True Case age <= 24 Select Case height Case Is <= 150 GetIdealWeight = 57 Case Is <= 160 GetIdealWeight = 60 Case Else GetIdealWeight = 63 End Select Case age <= 29 Select Case height Case Is <= 150 GetIdealWeight = 60 Case Is <= 160 GetIdealWeight = 63 Case Else GetIdealWeight = 66 End Select Case age <= 39 Select Case height Case Is <= 150 GetIdealWeight = 61 Case Is <= 160 GetIdealWeight = 64 Case Else GetIdealWeight = 68 End Select Case age <= 49 Select Case height Case Is <= 150 GetIdealWeight = 64 Case Is <= 160 GetIdealWeight = 67 Case Else GetIdealWeight = 71 End Select Case Else 'age >= 50 لاكثر من 50 سنة Select Case height Case Is <= 150 GetIdealWeight = 67 Case Is <= 160 GetIdealWeight = 70 Case Else GetIdealWeight = 74 End Select End Select End Function

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

السلام عليكم ورحمة الله وبركاته عزيزي المنتسب عند وضع مثالك يجب ان يكون المثال واضح ومفهوم ومبين كل ما تطلبه حتى يتسنى لشباب فهم طلبك وحله سريعا لأن الشباب هنا لديهم أشغالهم اليومية ولكن يستقطعون جزء من وقتهم لمساعدتك ويبذلون جهد كبير لأثبات انهم قادرون على حل مسألتك سوا مجهود فردي أو جماعي فيتوجب عليك بعد حل مسألتك التالي: 1 – الشكر لله أولا وثم الشكر لمن قام بمساعدتك ثانيا 2 – وضع أشاره أفضل إجابة على الإجابة التي تناسب طلبك 3 – وضع لأيك لمن حل طلبك أو شارك في الحل (من لا يشكر الناس لا يشكر الله)

لإبداء الرأي والتعديل . اقرأ الملف جيداً وجرب أولاً بالموجود بالجدول. ثم 1- اضافتة ملف الأكسل حقك بمجلد البرنامج 2- اضافة البيانات كما بالجدول (اسم ملف الأكسل بإمتداده - اسم ورقة الهمل التي تريدها) وإذا أكثر من ورقة كرر هذا السطر لكل ورقة عمل . رجاء ألا تبخلوا عليا بالرد أو المشورة . واليكم المرفق........ DD117.rar

تم تعديل الكود ليأخذ سطرا واحدا Private Sub Command138_Click() Dim i As Object, Msg$, T#, F#, U# For Each i In CreateObject("Scripting.FileSystemObject").Drives With i If .IsReady And .DriveType = 1 Then T = .TotalSize: F = .FreeSpace: U = T - F If Len(Msg) Then Msg = Msg & vbLf & vbLf Msg = .DriveLetter & ":" & " " & .VolumeName & " " Msg = Msg & "(" & .FileSystem & ")" & " " Msg = Msg & "(" & FormatSize(T) & "Tot" & ")" & " " Msg = Msg & "(" & FormatSize(F) & "free" & ")" & " " Msg = Msg & "(" & FormatSize(U) & "used" & ")" End If End With Next If Len(Msg) Then coDesks.AddItem Msg End Sub وهذه وحدة نمطية لارجاع حجم الرقم او ما يسمى السعة Public Function FormatSize(ByVal Size As Currency) As String Const Kilobyte As Currency = 1024@ Const TenK As Currency = 10240@ Const HundredK As Currency = 102400@ Const ThousandK As Currency = 1024000@ Const Megabyte As Currency = 1048576@ Const TenMeg As Currency = 10485760@ Const HundredMeg As Currency = 104857600@ Const ThousandMeg As Currency = 1048576000@ Const Gigabyte As Currency = 1073741824@ Const TenGig As Currency = 10737418240@ Const HundredGig As Currency = 107374182400@ Const ThousandGig As Currency = 1073741824000@ Const Terabyte As Currency = 1099511627776@ Select Case Size Case Is < Kilobyte: FormatSize = Int(Size) & " bytes" Case Is < TenK: FormatSize = Format(Size / Kilobyte, "0.00") & " KB" Case Is < HundredK: FormatSize = Format(Size / Kilobyte, "0.0") & " KB" Case Is < ThousandK: FormatSize = Int(Size / Kilobyte) & " KB" Case Is < TenMeg: FormatSize = Format(Size / Megabyte, "0.00") & " MB" Case Is < HundredMeg: FormatSize = Format(Size / Megabyte, "0.0") & " MB" Case Is < ThousandMeg: FormatSize = Int(Size / Megabyte) & " MB" Case Is < TenGig: FormatSize = Format(Size / Gigabyte, "0.00") & " GB" Case Is < HundredGig: FormatSize = Format(Size / Gigabyte, "0.0") & " GB" Case Is < ThousandGig: FormatSize = Int(Size / Gigabyte) & " GB" Case Else: FormatSize = Format(Size / Terabyte, "0.00") & " TB" End Select End Function Database4.rar

اللي فاهم يفهمني!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

¨جزاك الله خيرا وجعله في موازين حسناتك

السلام عليكم استاذ @سامر محمود اسف عن التأخير فقد ضيعت الموضوع لانك ولامرة عاملي تنبيه..على كل حال عملت جدول بالاجازات وجدول انواع الاجازات وعملت استعلام لحساب رصيد الاجازات المستحقة مع استعلام للاجازات المستنفدة..وعملت نموذج منح الموظف اجازة ..ونموذج اخر يعطيك خدمة الموظف سواء مدة خدمته او ماتبقى له من اجازات VACATIONS.rar

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

وعليكم السلام.. استخدم السطر التالي في مصدر سجلات الديون في التقرير..ولو المفروض تغيير اسم الاستعلام ولايكون مشابها لاسم الحقل اذا يعطي خطأ قم بتغيير الفاصلة الى فاصلة منقوطة =DLookUp("[SumOfMONT]","[SumDOYON]","[coud]=" & [coud])

نعم استاذ @محمد احمد لطفى انظر للمرفق hard disk2.rar

كيفية اضافة صف اتوماتيكيا مجرد كتابة اي بيان باستخدام الفيجوال بيسك فيديوووووو جديددددد في هذا الفيديو هانتعلم ازاي نضيف صف اتوماتيكيا باستخدام الفيجوال بيسك بطريقة سهلة ومبسطة وخطوة خطوة وكمان في الفيديو ترقيم تلقائي بمجرد كتابة اي بيان يعد هذا الفيديو مفيدًا للأشخاص الذين يستخدمون اكسيل في عملهم اليومي، سواء كانوا محاسبين أو مسؤولين عن قواعد البيانات أو مستخدمين عامين لهذا البرنامج

لا تعب هل من الممكن عرض ما توصلت إلية؟ لللإفادة

تفضل .. منقول ... Const MB& = 1048576 Dim i As Object, Msg$, T#, F#, U# For Each i In CreateObject("Scripting.FileSystemObject").drives With i If .IsReady And .DriveType = 1 Then T = .TotalSize / MB: F = .FreeSpace / MB: U = T - F If Len(Msg) Then Msg = Msg & vbLf & vbLf Msg = "Drive " & .DriveLetter & ":" & vbTab Msg = Msg & .VolumeName & " (" & .FileSystem & ")" Msg = Msg & vbLf & "Total size:" & vbTab Msg = Msg & Format(T, "#,##0 MB") & vbLf Msg = Msg & "Free space:" & vbTab Msg = Msg & Format(F, "#,##0 MB") & vbLf Msg = Msg & "Used space:" & vbTab Msg = Msg & Format(U, "#,##0 MB") End If End With Next If Len(Msg) Then MsgBox Msg

🤔

Dim i As Integer, R As Integer Dim rs As Recordset Dim x As String Set rs = Me.RecordsetClone rs.MoveLast R = rs.RecordCount rs.MoveFirst x = txt_nshat For i = 1 To R rs.Edit rs.Fields(x) = drga2 rs.Update rs.MoveNext Next غفلت عن تعديل آخر سطر MsgBox ("تم رصد نشاط") & " ( " & Me.txt_nshat & " ) " بدله بهذا MsgBox ("تم رصد نشاط") & " ( " & Me.txt_nshat.Column(1) & " ) " التعديل الذي تم انظر في جدول tb_nshat وانظر في مصدر بيانات مربع التحرير رصد الانشطة2.rar

السلام عليكم و رحمة الله اجعل المعادلة هكذا =IF(AND(COUNTIF($AH$1:$AH$7;$H8)>0;COUNTIF($AH$1:$AH$7;$J8)>0);3;IF(COUNTIF($AH$1:$AH$7;J8)>0;2;IF(COUNTIF($AH$1:$AH$7;H8)>0;1;"")))

هذا المثال قد يفيدك مثال سند.accdb

أخي @طاهر الوليدي كلامي في الاعلى لم يكن موجهاً لك أخي الغالي .. وانما كان موجه الى احد الاخوة الذي احترمه احتراما كبيراً .. كان قد انتقدني في موضوع سابق عندما طلبت ان يرفق لنا ملفه .. والان ارى ردا من ردوده متناقضاً عما قاله سابقاً في انه يريد ان يكون الموضوع محصور كاملا في مجال معين ( برنامج كامل ) وليس ملفا فقط .. فيادنيا العجب

قم بعمل كومبوبوكس يعيد لك السجل الذي تريد التعديل عليه بالتوفيق

وجدت لك هذا المرفق يشتمل على بعض الجداول الاساسية ، اعجبني التصميم لعلك تستفيد منه account.mdb

كأني رأيت المرفق من قبل تفضل تم اضافة زر للنسخ تأكد اولا من اعدادات مكان القاعدة ومكان النسخة MS_LOGO2.rar

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

هكذا؟ Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6), a(i, 7), a(i, 8))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8) .Item(a(i, 1)) = w End If Next For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(14, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub اذا لم يكن المطلوب أرجو أن ترفق ملف فيه النتائج المتوقعة شكراً

الحمد لله الذي بنعمته تتم الصالحات

تفضل أخي الكريم استبدل باكود: Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) .Item(a(i, 1)) = w End If Next itm = .items For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(UBound(a, 2) - 4, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub

قبل لا نخرج عن الموضوع الرئيسي .. 🙂 الفكرة هي التصويت على الأفكار المتميزة بمختلف مواضيعها ثم تسليط الضوء عليها وتكريم أصحابها .. المشاريع الجماعية فكرة أخرى سننظر فيها لاحقاً .. 😄

You have to know the cause of the error. In the procedure [Private Sub CommandButton3_Click()], you have declared a varaible name [Lsrch] Lsrch = RM3.Range("k5").Value But the sheet RM3 in cell K5 is empty and this causes the error. The cell K5 should have a number, so try to put a number in cell K5 in sheet RM3 and there will be no errors

اعمل نموذج بالشكل الذي ترغبه وبالابعاد التي تريدها وليس (الحجم) ...وانسخه بعدد النماذج التي تريدها

أخي @ehabaf2 هذه مسألة طبيعية خاصة عند وجود بيانات كثيرة على ورقة العمل من الأفضل إستبدال طريقة تنفيذ الكود من حدث الشيت إلى Module Sub Masquer_Columns() StartColumn = 6 ' اول عمود LastColumn = 176 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn If Range("B20").Value = "" Then 'From column 6 to column 170 Columns("F:FS").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i Application.ScreenUpdating = True End Sub كود اخفاء v2.xlsm

بما انك مصر على نفس الفكرة ونفس اليوزرفورم تفضل اخي يمكنك تغيير الاكواد بالشكل التالي تمت اظافة كومبوبوكس لاختيار عمود البحث و تكست بوكس للبحث بالحروف الاولى Dim f, rng, MH(), Ncol '21/02/2022 اوفيسنا Private Sub UserForm_Initialize() Dim ST Set f = Sheets("Follow up") Set rng = f.Range("A5:J" & f.[A65000].End(xlUp).Row) MH = rng.Value ST = f.[A4].CurrentRegion.Columns.Count Me.ListBox1.ColumnCount = ST Set plage = f.[A4].CurrentRegion Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1) x = Me.ListBox1.Left + 8 y = Me.ListBox1.Top - 12 For i = 1 To ST Set Lab = Me.Frame1.Controls.Add("Forms.Label.1") Lab.Caption = f.Cells(4, i) Lab.Top = y Lab.Left = x x = x + f.Columns(i).Width * 1.02 temp = temp & f.Columns(i).Width * 1.02 & ";" Next temp = Left(temp, Len(temp) - 1) Me.ListBox1.ColumnWidths = temp Me.Frame1.ScrollWidth = Me.ListBox1.Width + 10 Me.Frame1.ScrollBars = 1 ' Me.ListBox1.List = plage.Value ' يمكنك تفعيل هدا الخيار لاظهار البيانات على الليست بوكس Me.ComboChoixColFiltre.List = Application.Transpose(rng.Offset(-1).Resize(1)) Me.ComboChoixColFiltre.ListIndex = 0 Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboChoixColFiltre_click() Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub CommandButton1_Click() If Recherche.Value = Empty Then MsgBox "المرجوا ادخال معيار البحث", vbInformation + vbMsgBoxRight + vbMagBoxRt1Reading, "تعليمات" Exit Sub End If colRecherche = Me.ComboChoixColFiltre.ListIndex + 1 clé = "*" & Me.Recherche & "*": N = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, colRecherche) Like clé Then N = N + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To N) For k = 1 To UBound(MH, 2): Tbl(k, N) = MH(i, k): Next k End If Next i If N > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Recherche_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then Recherche.Value = Empty End If End Sub ملاحظة البحث يكون فقط على نفس الشيت Test_User.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_SelectionChange(ByVal Target As Range) StartColumn = 6 ' اول عمود LastColumn = 40 ' اخر عمود iRow = 20 ' رقم الصف Application.ScreenUpdating = False For i = StartColumn To LastColumn Application.ScreenUpdating = False If Range("b20").Value = "" Then Columns("F:H").EntireColumn.Hidden = False Exit Sub End If If Cells(iRow, i).Value > Range("b20").Value Then Cells(iRow, i).EntireColumn.Hidden = True Else Cells(iRow, i).EntireColumn.Hidden = False End If Next i End Sub كود اخفاء.xlsm

لحل هذه المشكلة تفضل مثال والشرح عليه . PhoXo112.bmp

اخى @طارق نادر قم بقراءه المشاركه جيدا ستجد انني كاتب لك الخطوات جيدا اين الخطوة التي بها صعوبه حتى اشرحها لك