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

Very weird I have commented this line as I didn't want to print Rem sh.PrintOut Rem is used to make the line as a comment. Just remove the Rem and the sheet will be printed Another point I have put this line just for wait, you can remove this line Application.Wait Now + TimeValue("00:00:01") Try to understand the code. Don't wait others to do the whole work for you

Try Sub Test() Dim a, e, ws As Worksheet, sh As Worksheet, i As Long Set ws = ThisWorkbook.Worksheets(1): Set sh = ThisWorkbook.Worksheets(2) a = ws.Range("B11:J" & ws.Cells(Rows.Count, "B").End(xlUp).Row).Value e = sh.Range("Q3").Value For i = LBound(a) To UBound(a) If a(i, 8) = e Then sh.Range("F9").Value = a(i, 2) sh.Range("M9").Value = a(i, 9) Application.Wait Now + TimeValue("00:00:01") Rem sh.PrintOut End If Next i End Sub

Try Sub Test() Dim lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row With .Sort .SortFields.Clear .SortFields.Add Key:=Range("F3"), Order:=xlAscending .SortFields.Add Key:=Range("G3"), Order:=xlDescending .SortFields.Add Key:=Range("H3"), Order:=xlAscending .SetRange ActiveSheet.Range("A3:H" & lr) .Header = xlYes .Apply End With End With End Sub

العفو اخي احمد تفضل مع اظافة أكواد تحديد أو استثناء أوراق معينة Sub Copy_Data() Dim ws As Worksheet Dim i&, j&, lr As Long For Each ws In Sheets lr = ws.Range("k" & Rows.Count).End(xlUp).Row + 1 ws.Range("k2:L" & lr).ClearContents j = 2 For i = 2 To ws.Range("A" & Rows.Count).End(3).Row If ws.Range("B" & i).Value <> "" Then ws.Range("K" & j & ":L" & j).Value = ws.Range("A" & i & ":B" & i).Value j = j + 1 End If Next Next End Sub بالتوفيق ورقة عمل V2.xlsm

Try Sub Test() Dim ws As Worksheet, sh As Worksheet, tbl As ListObject, lr As Long, i As Long Application.ScreenUpdating = False With ThisWorkbook Set ws = .Worksheets("Items"): Set sh = .Worksheets("Orders") End With Set tbl = sh.ListObjects(1) lr = tbl.Range.Rows.Count + tbl.Range.Row - 1 Do While sh.Cells(lr, "C").Value = Empty lr = lr - 1 Loop lr = lr + 1 Dim a(1 To 16), e For Each e In Split("H15,F4,F6,H6,F9,H9,J9,F13,H13,J13,F15,J15,F18,H18,J18,F20", ",") i = i + 1 a(i) = ws.Range(e).Value Next e sh.Range("C" & lr).Resize(, 16).Value = a Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

السلام عليكم ورحمة الله وبركاتة ....................................... كل عام وحضراتكم بخير وصحه وعافية رفعت هذا البرنامج للفائدة برنامج محاسبة العمال بالدقيقة 🕒 البرنامج سهل الاستخدام يتم اصافة عميل -حذف عميل .. كما يوجد شيت داخل البرنامج لشرح استخدامة صورة توضيح الاستتخدام هنا الصفحة الرئسية هنا الصفحة المنسوخ منها صفحة العميل الجديد وهذة صفحة شرح كيفية استخدام البرنامج البرنامج في المرفقات برنامج محاسبة العامل بالساعة-1-6-2023-.xlsb

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

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

استخدمت لك كود استاذ ابو احمد اما كود استاذ محمد عصام فيحتاج الى فاكتور في النموذج aaa.rar

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

تفضل أخي . base (2)-1.accdb

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

دالة على السريع، جربها ويمكننا تطويرها بعد التجارب: Function myRound(ByVal Num As Double) As Double Dim Frac As Double Num = Num / 10 Frac = Num - Int(Num) Frac = IIf(Frac = 0, 0, IIf(Frac > 0.5, 10, 5)) myRound = Int(Num) * 10 + Frac End Function

اتفضل يا سيدى اولا قم بعمل وحدة نمطية وضع بها الاكواد الاتية Public Function Ceiling(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double ' X is the value you want to round ' is the multiple to which you want to round Ceiling = (Int(X / Factor) - (X / Factor - Int(X / Factor) > 0)) * Factor End Function Public Function Floor(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double ' X is the value you want to round ' is the multiple to which you want to round Floor = Int(X / Factor) * Factor End Function استدعاء الدالة كالاتى Ceiling([SourceNumber],variableOfFixedNumber) التقريب الى الرقم الصحيح 5 يمكنك تغسييره الى ما تريد وليكن 10 او 20 او اى عدد تريده -------- الطريقة الثانية ولكن لن تستطيع تغيير الرقم الذى تريد التقريب اليه استخدم الكود الاتى مباشرة Int(-0.2*[SourceNumber])/-0.2

تحسين بسيط على الكود .. وهو حتى كلمات البحث تطبق عليها دالة تجاهل الهمزات 🙂 فلو كتبت في البحث ( أحمد ) تظهر جميع النتائج .. أحمد .. احمد .. إحمد .. وهكذا .. بحث بعدد 3الكلمات.rar

اشكرك أستاذى الغالى هو المطلوب بالفعل

مشاركة مع اساتذتي تفضل هذا المرفق ووافني بالرد . تفعيل وايقاف اضافة سجل للمكرر-1.mdb

تفضل هذا التعديل تفعيل وايقاف اضافة سجل للمكرر.mdb

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

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

اليك حل اخر Sub CopyData() Dim x, y(), i&, lr&, ws_rng2&, ws_rng3& Set ws_rng = Sheet1 lr = ws_rng.Range("A" & Rows.Count).End(xlUp).Row x = ws_rng.Range("A2:B" & lr) For i = 1 To UBound(x, 1) If x(i, 2) <> 0 Then ws_rng3 = ws_rng3 + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ws_rng3) For ws_rng2 = 1 To UBound(x, 2) y(ws_rng2, ws_rng3) = x(i, ws_rng2) Next End If Next ws_rng.Range("k2").Resize(ws_rng3, UBound(y, 1)) = Application.Transpose(y) End Sub آسف لم انتبه لمسألة تعدد أوراق العمل لعدم وجودها على الملف المرفق سوف أقوم باظافتها لاحقا. فقط لاثراء الموضوع لا أكثر.فحل الأستاذ @محي الدين ابو البشر يوفي بالغرض ورقة عمل جديد.xlsm

عليكم السلام ورحمة الله وبركاته ما رأيك بكود Sub test() Dim a Dim i&, ii& Dim sh As Worksheet For Each sh In Worksheets ii = 1 a = sh.Cells(1).CurrentRegion ReDim b(1 To UBound(a), 1 To UBound(a, 2)) For i = 2 To UBound(a) If a(i, 2) <> "" Then b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2) ii = ii + 1 End If Next sh.Cells(2, 11).Resize(ii, 2) = b Next End Sub ورقة عمل Microsoft Excel جديد (2).xlsm

وعليكم السلام ورحمة الله وبركاته اخى الكود الذي وضعته لك يقوم ب ١- اخغاء جميع الصفحات من الشيت ٢-اظهار الصفحه التى تكون بأسم المستخدم يعني مستخدم knt يفتح صفحه knt 3-اذا كان اسم المستخدم ليس له صفحه يتم اظهار صفحه الرقم السري فقط انت عامل صفحه اسمها control فيها الباسوورد وفيها اعمده فيها yes و No عندما تضع yes أمام اسم مستخدم سوف يفتح صفحه اخري غير الصفحه التي تسمي باسمه عندما تضع no لا يتم فتح غير صفحته الخاصه فقط

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

موعدنا اليوم مع تطبيق ضمن سلسلة ما خف وزنه وغلا ثمنه لأحبابي أعضاء وزوار منتدى أوفيسنا تطبيق يساعدك في إنشاء رسائل msgbox بصورة احترافية فقط اختر الأزرار والعنوان ونص الرسالة والأيقونة وباقي الخيارات ثم اضغط على زر تجربة لمشاهدة كود الرسالة ثم قم بنسخ الكود لبرنامجك ويمكنك استخدام الثوابت والقيم في كتابة الكود وفي الأخير لا ينقصني سوى دعاؤكم msgboxbuilder.rar

sabah2023 عليك بالضغط على أفضل إجابة !!!

حسب الصورة عسى Sub Test() Dim i& For i = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(i, 1).Interior.Color = vbYellow Then Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Cells(i, 1).Value Next End Sub Book1.xlsm

عليكم السلام عسى رصيد لكل مادة حسب المخزن.xlsx

تفضل جرب Private Sub TextBox26_Change() Dim CelF As Range, LigF As Long Set ws = ActiveWorkbook.Sheets("Data") With ws Set lst = ws.ListObjects("الجدول1") If lst.ShowAutoFilter Then lst.ShowAutoFilter = False End If Set CelF = ws.Range("Find").Find(What:=Me.TextBox26, LookIn:=xlValues, LookAt:=xlWhole, _ SearchDirection:=xlNext, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not CelF Is Nothing Then LigF = CelF.Row Label1.Caption = ws.Range("B" & LigF) Label2.Caption = ws.Range("C" & LigF) Label3.Caption = ws.Range("E" & LigF) Label4.Caption = ws.Range("D" & LigF) Else For S = 1 To 3 Me("Label" & S) = Empty Next S End If End With Label2 = Format(Label2, "dd/mm/yyyy") Label2.BackColor = &H8000000F End Sub TEST V1.xlsb