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

أشكرك أخي الكريم @ابوحبيبه على كلامك الطيب المشجع ،وأقول لك أخي الكريم ولكم بمثل ما دعوتم....آمين نحن كما ذكرت نكبر ببعضنا ونتشارك العلم الذي وهبنا الله إياه ...وكما رأيت لكلِ أسلوبه ولذلك فإن هذا المنتدى هو مرتع خصب للتحصيل العلمي ولشرف الريادة والسبق في ميادين العلم الذي قال الله تعالى عنه: (وقل ّربّ زدني علماً) وقال تعالى أيضاً : ( وفوق كل ذي علمٍِ عليمٌ) جزاك الله خيراً على حسن الظن بإخوانك ، تقبل تحياتي العطرة والسلام عليكم

Here's the code and please try to learn from the solutions as it is a bad attitude to wait the help all the time from other people Sub Test() Dim a, e, sh As Worksheet, f As Boolean, lr As Long, r As Long Application.ScreenUpdating = False Set sh = ThisWorkbook.Worksheets("Saad") f = True: sh.Cells.ClearContents For Each e In Array("Sheet1", "Sheet2", "Sheet3") With ThisWorkbook.Worksheets(e) lr = .Cells(Rows.Count, "M").End(xlUp).Row a = .Range("K5:X" & lr).Value If f Then r = 5: f = False Else r = sh.Cells(Rows.Count, "C").End(xlUp).Row + 1 sh.Cells(r, "C").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With Next e Application.ScreenUpdating = True End Sub

بارك الله بكم أخي الكريم @Mohamed Hicham وبعلمكم آمين كان جوابي على قدر سؤال الأخ السائل إذ تم فصل الأسطر فيما بينها بأسطر فارغة في الكود المدرج من قبله Private Sub Workbook_Open() MyPassword = "123" For Each MySheet In ActiveWorkbook.Sheets MySheet.Protect _ Password:=MyPassword, _ DrawingObjects:=True, _ Contents:=True, _ Scenarios:=True, _ UserInterfaceOnly:=True Next MySheet End Sub وبعد ضبط الكود كما يجب تمت تجربته وتزويد الأخ السائل به أشكرك أخي الكريم على حسن استئذانك و لين جانبك ... وأزيدك من الشعر بيتاً أنني معجب بعلمك ومساعدتك للآخرين وهذا ما نتوسمه بالجميع ولذلك فإنني أغبطك وأسعد بذلك تقبل تحياتي العطرة. والسلام عليكم

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد @محمد حسن المحمد Private Sub Workbook_Open() MyPassword = ("123") For Each Worksheet In ActiveWorkbook.Worksheets Worksheet.protect Password:=MyPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True Next End Sub ما الخطأ في هذا الكود.xlsm

Try this Option Explicit Sub Add_Circles() Dim ws As Worksheet, myRng As Range, c As Range, v As Shape, col As Long Application.ScreenUpdating = False Set ws = ActiveSheet Set myRng = ws.Range("F3:N13") myRng.RowHeight = 35: myRng.ColumnWidth = 10 Call Remove_Circles For Each c In myRng.Cells col = c.Column If c.Value < ws.Cells(2, col) Or c.Value = Chr(219) Then Set v = ws.Shapes.AddShape(msoShapeOval, c.Left + 15, c.Top + 2, 30, 30) With v With .Fill .Visible = msoTrue .ForeColor.RGB = RGB(166, 166, 166) End With With .TextFrame2 .TextRange.ParagraphFormat.Alignment = msoAlignCenter With .TextRange.Font .Fill.ForeColor.RGB = RGB(0, 0, 0) .Size = c.Font.Size .Bold = c.Font.Bold .Name = c.Font.Name End With .WordWrap = msoFalse End With With .TextFrame .Characters.Text = c.Value .MarginRight = 4 .MarginTop = 2 .MarginLeft = 4 .MarginBottom = 2 End With End With End If Next c Application.ScreenUpdating = True End Sub Sub Remove_Circles() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp End Sub

So clear

When protecting the worksheet, you have to follow these steps Review Tab >> Click on Protect Sheet Check the option Edit Objects Enter your password if you desire and you can leave it empty

Select cell A18 View Tab Freeze Panes Freeze Panes

كريم نظيم جزاك الله خير المعادلة تمام شكراً لتعبك ياغالي

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

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

السلام عليكم بالإذن منكم باعتبار لا يوجد ملف مرفق إذا كانت الداتا في Sheet1 ,وتبدأ من A1 والنتيجة في sheet2 العمود A1 down Sub test() Dim cel As Range Dim i& With CreateObject("VBScript.RegExp") .Global = True For Each cel In Sheets("sheet1").UsedRange.Cells .Pattern = "[05 ]*[\d]{8}" If .test(cel) Then Sheets("sheet2").Cells(i + 1, 1) = .Execute(cel)(0) i = i + 1 End If Next End With End Sub

Here's a modified udf to be compatible with older versions of excel Function DistributeNumber(ByVal num As Long, ByVal chunks As Long, ByVal iIndex As Long) Dim i As Long ReDim b(chunks - 1) For i = 0 To chunks - 1 If i = chunks - 1 Then b(i) = num Else b(i) = WorksheetFunction.RoundUp(num / (chunks - i), 0) num = num - b(i) End If Next i On Error Resume Next DistributeNumber = b(iIndex - 1) If Err.Number <> 0 Then DistributeNumber = vbNullString: Err.Clear On Error GoTo 0 End Function you can use the udf as formula (but you will have to drag the formula) Say the number is K1 so the formula in cell K2 should be =DistributeNumber(K$1,5,ROW(A1)) Drag the formula down to get the results

وعليكم السلام ورحمه الله وبركاته يمكنك استخدام هذاه ان شاءالله يكون المطلوب وتفي الغرض اختر ما تشاء =IFS(IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100)>1000,1000,IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100)<1000,IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100)) او =IF((C3-A6+D3)*11/100>1000, 1000, IF((C3-A6<0), D3*11%, (C3-A6+D3)*11/100)) او =MIN(MAX(IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100),0),1000) =MIN(MAX(IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100),0),1000) =IFS(IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100)>1000,1000,IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100)<1000,IF(C3-A6<0,D3*11%,(C3-A6+D3)*11/100))

احببت ان افرد موضوعي هذا بعنوان مستقل 1-لان غالب او جميع الدروس هنا تتعامل مع واتساب ويندوز 2-وحتى يكون تطوير هذا العمل مستقلا ولا يحدث خلط بين الامثلة المثال المرفق تم تطبيقه على واتساب ويب واليكم بعض التوجيهات والملاحظات : كانت مشكلتي في محاولات سابقة انه في كل مرة يتم الارسال وفتح الواتساب ويب .. فانه يطلب ربطا جديدا بالجوال وبحمد الله توصلت الى حل هذه المشكلة التي كانت عائقا حقيقيا .. يكتفى بالارتباط مرة واحدة فقط الآن : عند كل ارسال يفتح الواتس ويب بشاشة جديدة .. فان كانت هناك نسخة مفتوحة من قبل فانه يتجاهلها وتصبح غير فعالة وهذه لا مشكلة فيها لأنه يفتح على الحساب نفسه . ارجوا من اخوتي واحبتي الذين يمرون من هنا تجربة المثال وافادتي بنتيجة التجربة ، من اجل الانتقال الى الخطوة التالية وهي ارسال المرفقات ملحوظة : المرفق sendwatsWebAll .. هو النسخة المحدثة والمطورة بعد أخذ آراء وتجارب الإخوة sendwatsWeb.mdb sendwatsWebAll.rar

نعم أستاذ @AbuuAhmed كانت المشكلة في كود تحديث الاستعلام لحقل في احد النماذج. جزيل الشكر والتقدير لك..

تفضل تقسيم الى مجموعات.accdb.mdb

مشاركة مع الاستاذ @دروب مبرمج في حدث الحالي للنموذج الفرعي الاول ضع هذا الحدث ...... Dim rs As DAO.Recordset On Error Resume Next Set rs = Me.RecordsetClone rs.FindFirst "[ItemNumber] = " & Me![ItemNumber] Me.Parent.FrmSubInvoice.Form.Bookmark = rs.Bookmark

اخى خالد ارفق ملف بعد اتباع الخطوات

تفضل Database1.accdb

Dim strDB As String strDB = "C:\Users\ferry\Desktop\5555\FolderN\1010\bar.accdb" عدل للمسار الصحيح Set appAccess = CreateObject("Access.Application") appAccess.OpenCurrentDatabase strDB If appAccess.CurrentDb() Is Nothing Then MsgBox "فشل في فتح قاعدة البيانات!" Else appAccess.DoCmd.OpenForm "LoadingBar" appAccess.Visible = True End If 5556.rar

Maybe someone else will attach the file for you

Very good MR lion

اسف لعدم الرد فقد كنت على سفر لاتنسى ان تضع الاسطر التالية قبل وبعد جمل التحديث والحذف حتى لا تظهر لديك رسائل الاكسس DoCmd.SetWarnings False DoCmd.RunSQL DoCmd.SetWarnings True

شكرا جزيلا استاذنا الفاضل

The code already did that Not clear problem for me. Wait for other members

Change the column width and addshape line to suit you

الف مليون شكر اشتغلت بفضل الله واسف انى ارهقت حضرتك

Great my bro That is my try Sub Test() Call Generate_Random_Numbers Call Extract_Valid_Numbers_Only End Sub Private Sub Generate_Random_Numbers() Dim i As Long With ActiveSheet With .Columns("A:B") .ClearContents: .NumberFormat = "@": .ColumnWidth = 20 End With .Range("A1").Resize(, 2).Value = Array("Numbers", "Result") ReDim a(1 To 100, 1 To 1) For i = LBound(a) To UBound(a, 1) a(i, 1) = GenerateNumber() Next i .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With End Sub Function GenerateNumber() As String Dim a, sRanNum As String, sPrefix As String, iLen As Long a = Array("02", "05") iLen = WorksheetFunction.RandBetween(8, 11) sPrefix = a(WorksheetFunction.RandBetween(0, UBound(a))) sRanNum = sPrefix & Format(Application.WorksheetFunction.RandBetween(10 ^ (iLen - 3), (10 ^ (iLen - 2)) - 1), String(iLen - 2, "0")) GenerateNumber = sRanNum End Function Private Sub Extract_Valid_Numbers_Only() Dim a, ws As Worksheet, n As Long, i As Long Set ws = ActiveSheet a = ws.UsedRange.Columns(1).Value ReDim b(1 To UBound(a, 1), 1 To 1) n = 1 With CreateObject("VBScript.RegExp") .Global = True For i = 1 To UBound(a, 1) .Pattern = "^05\d{8}$" If .Test(a(i, 1)) Then b(n, 1) = .Execute(a(i, 1))(0).Value n = n + 1 End If Next i End With ws.Range("B2").Resize(UBound(b, 1), UBound(b, 2)).Value = b End Sub There are two codes: the first code will generate random numbers and the second code will extract the valid numbers only

May God bless you

حقيقة لم افهم المقصود بشكل جيد هلا تكرمت بمزيد من التوضيح مثل ماذا تعني بالتقسيم الي مجموعات واين تريد ان يظهر هذا التقسيم في جدول ام تقرير وماذا تعني بتغير المجموعات وعلي اي اساس يتم التغير اعتذر لعدم افادتك بالوقت الحالي، ولكن كما تعلم فان فهم السؤال شطر الجواب كما يقال

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

حل اخر ادا لم يكن عندك مانع في طريقة ترتيب التوزيع Sub Dis_numbers() Dim rng As Range Dim rng2 As Range Dim cell As Range 'الخلايا المستهدفة Set rng = Range("I3,F3,C3,N12") For Each cell In rng Set rng2 = Range(cell.Offset(1, -1), cell.Offset(4, -1)) rng2.Value = Int(cell.Value / 5) cell.Offset(0, -1).Value = cell.Value - Application.WorksheetFunction.Sum(rng2) Next cell End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''حدث ورقة 1''''''''''''''''''' Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Row Number If Target.Row = 3 Then Exit Sub Select Case Target.Column 'Columns Case 3, 6, 9 Call Dis_numbers End Select ' Cell N12 'Column ("N") If Target.Row = 12 Then Exit Sub Select Case Target.Column Case 14 Call Dis_numbers End Select End Sub توزيع رقم 3.xlsb

القاعدة كبيرة و لم استطع ارفاقها قمت بحذف الجداول لكي يتضح المثال الصق الشفرة التالية في موديول جديد و يجب عليك التدقيق في اسماء الأعمدة التي في الشفرة و التأكد من انها هي المستهدفة في عملية الاحتساب Public Function GetSubProduct(Product_NO As String) As Integer Dim SubProduct As Integer, OutProduct As Integer, SubTotal As Integer SubProduct = Nz(DSum("[UOM_UNIT_QTY]", "[ITEMS]", "[ITEM_CODE] Like '" & Product_NO & "'"), 0) OutProduct = Nz(DSum("[QTY_UNITS]", "[MISCELLANOUS_SALES_LINES]", "[ITEM_CODE] Like '" & Product_NO & "'"), 0) SubTotal = SubProduct - OutProduct GetSubProduct = SubTotal End Function و لإستدعاء الوظيفة اعلاه GetSubProduct("كود الصنف") و هنا تم التطبيق على الاستعلام مرفق مثال مصغر Database1.mdb

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

السلام عليكم أهلا بكم... هذه مشاركة بسيط ضمن هذا العنوان العريض.. نموذج يقوم بالبحث في المنتى ويعيد البيانات التالية (رقم المشاركة، عنوان المشاركة، موضوع المشاركة) ويخزنها في جدول البيانات، مع ربط عنوان المشاركة بالموقع.. البحث في عناوين المشاركات فقط.. إذا كان مجال البحث يتضمن صفحات متعددة فإنه يعيد بيانات الصفحة الأولى في هذه المرحلة... سوف أناقش إن شاء الله،، فيما بعد مفاتيح البحث التي يقدمها الموقع وكيفية الاستفادة منها.. إليكم المشاركة.. SearchInOfficena.accdb

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

فيديووووو جديددددد كيفية دمج عدة ملفات بهيدرز مختلفة في ملف واحد باستخدام الكويري في الفيديو دة هاتقدر تتدمج ملفات كثيرة في ملف واحد بس خلي بالك الملفات فيها اعمدة مختلفة >> يعني كل ملف في اعمدة مختلفة فا في الدرس ده هانتعلم نلم كل الاعمدة في ملف واحد https://youtu.be/2oXx8bt-1m0 جلب كل اسماء الاعمدة من الملفات.rar