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

تم تعديل البرنامج مع اضافة الباركود اسفل الورقة. *ملاحظة هامة* يتم تثبيت خطوط الباركود المرفقه مع البرنامج لكي يظهر الباركود بصورة صحيحة اسفل ورقة الاختبار برنامج طباعة الاختبارات تعديل نهائي٣.rar

طيب خبرني النتيجة yy (1).rar

ممكن نسخة 2003 بعد اذنك و شكرل

حل اخر يغنيك عن كتابة الاكواد في الورقة "الورقة 1" ، ضع أسماء النماذج في العمود A وفي العمود B وقت كل نموذج ، كما هو موضح في المثال التالي: 2) قم بتشغيل هذا الماكرو: 😁 Sub View_User() Dim uForm As Object Dim i As Long Dim MyRng As Variant Dim Nameform As String On Error Resume Next MyRng = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("B" & Rows.Count).End(3)) Application.Visible = False For i = 1 To UBound(MyRng) Nameform = MyRng(i, 1) Set uForm = CallByName(UserForms, "Add", VbMethod, Nameform) DoEvents uForm.Show 0 Application.Wait Now + TimeValue("00:00:" & MyRng(i, 2)) DoEvents Unload uForm Next Application.Visible = True On Error GoTo 0 End Sub اليك الملف للفائدة تجربة 4.xlsm

اليك اخي طريقة اسرع في حالة وجود عدد كبير من الصفوف المرحلة الكود اطول لاكن اسرع بكثير من الاول 😄يمكنك ترحيل 400 صف في 2 ثواني تقريبا Sub Copy_Reports2() '''''''''''''''''' New additions to speed up code execution '""""""""""""""""""" Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim wsDest As Worksheet: Set wsDest = Worksheets("تقسيم") Dim sMsg As String, rHeaders As Range, ligne As Range, t1 As Range, t2 As Range Dim LastRow&, Titles&, Cpt&, lastCol&, col&, rngCell, r&, c As Range, Réf&, N& temps = Timer With Application .EnableEvents = False .ScreenUpdating = False End With limite = ws.Evaluate("SUM(0+(A4:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row & "<>""""))") Set rHeaders = ws.Range("A1:P3") Set ligne = wsDest.[A5] wsDest.Cells.Clear For x = 4 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If ws.Range("A" & x) <> "" Then: Rng = ws.Range("A4:P" & x) début = 1: TailleBloc = 10: décal = 0: Next Do While début <= UBound(Rng) fin = début + TailleBloc - 1: If fin > UBound(Rng) Then fin = UBound(Rng) b = Application.Index(Rng, Evaluate("Row(" & début & ":" & fin & ")"), Application.Transpose(Evaluate("Row(1:" & UBound(Rng, 2) & ")"))) If ligne = 0 Then wsDest.Range("a" & Rows.Count).End(xlUp).Offset(3).Resize(UBound(b), UBound(b, 2)) = b Else Réf = wsDest.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row wsDest.Range("A" & Réf + 6).Resize(UBound(b), UBound(b, 2)) = b End If décal = décal + UBound(Rng, 2) + 1: début = fin + 1 Loop wsDest.Activate With wsDest.Cells .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1 .RowHeight = 40: .Columns(10).ColumnWidth = 23: .Columns(15).ColumnWidth = 16: .Font.Size = 16: .Font.Name = "Arial" End With LastRow = wsDest.Range("A:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = wsDest.Range("A3 :P" & LastRow) rngCell.Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Cpt = 14 N = 1 For Titles = 1 To LastRow Step Cpt If wsDest.Cells(Titles, "A").Offset(5, 0) <> "" Then rHeaders.Copy wsDest.Cells(Titles, 1).Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False Set t1 = wsDest.Cells(Titles, "B").Offset(13, 0) Set t2 = wsDest.Cells(Titles, "C").Offset(13, 0) t1.Interior.Color = RGB(204, 255, 255): t1.Value = " رقم القائمة" t2.Value = N: t2.Interior.Color = RGB(204, 255, 255) Titles = Titles + 1 N = N + 1 End If Next Titles Application.CutCopyMode = False With wsDest For i = 3 To LastRow On Error Resume Next If wsDest.Cells(i, "M") Like "الكمية المحتسبة" And wsDest.Cells(i, "M").Offset(10, 0) <> "" Then 'تلوين الخلفية wsDest.Cells(i, "j").Offset(11, 0).Resize(, 7).Interior.Color = vbYellow: wsDest.Cells(i, "J").Offset(11, 0).Value = "المجموع" wsDest.Cells(i, "M").Interior.Color = vbYellow: wsDest.Cells(i, "O").Interior.Color = vbYellow 'الكمية المحتسبة wsDest.Cells(i, "M").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "M").Offset(1, 0), Cells(i, "M").Offset(10, 0))) 'المبلغ الكلي wsDest.Cells(i, "O").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "O").Offset(1, 0), Cells(i, "O").Offset(10, 0))) ' النقص wsDest.Cells(i, "P").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "P").Offset(1, 0), Cells(i, "P").Offset(10, 0))) End If Next i [A3].Select End With On Error GoTo 0 sMsg = " تم ترحيل" & " " & limite & " مستند " & " " & "بنجاح" MsgBox sMsg & vbCrLf & vbCrLf & " " & " " & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000"), Exclamation, "اوفيسنا" With Application .EnableEvents = True .ScreenUpdating = True End With End Sub اضافة رقم القائمة 2.xlsm

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

ربما لو اخترعنا طريقة لتعديل البيانات أو إضافتها عن طريق استعلامات التعديل والإلحاق أو ربما عن طريق فتح RecordSet بالكود .. يمكن إيجاد آلية لعمل ذلك .. نفس فكرة النماذج الغير منظمة لأي جدول أو استعلام .. أيش رايكم ؟ 🙂

هناك العديد من الامثلة حول البحث يمكنكم البحث وارفق لكم مثالا حول البحث بعدة معايير وبالكود DbSearch.rar

لمنع ترك الحقل فارغ بالتوفيق If IsNull(Me.اسم_الحقل) Then MsgBox "يجب ملء حقل الاسم قبل الحفظ.", vbExclamation, "تحذير" Cancel = True ' إلغاء عملية التحديث End If او If Me.اسم_الحقل= "" Then MsgBox "يجب ملء حقل الاسم قبل الحفظ.", vbExclamation, "تحذير" Cancel = True ' إلغاء عملية التحديث End If

غيرنا التشكيلة .... جرب المرفق بالضغط على التحديث الجديد وشاهد .... Replace&add.mdb

أخي @abood2626 لو حابب أزود عليه فورم دخول وصلاحيات أنا حاضر .

يمطنط استخدام هذه المعادلة في الخلية Q2 =SUMIFS(tr_acc[عدد النقل],tr_acc[رقم الوش],N5,tr_acc[التاريخ],M5) بالوفيق

أبسط هذه الطرق استعمال دالة image =IMAGE("https://quickchart.io/qr?size=100&text="&A2) خيث A2 هي الخلية التي بها النص المراد تحويله ولمن ليس لديه دالة image يمكن استخدام هذه الدالة المعرفة Function masqr(mytext As String) Dim URL As String, myrng As Range, myshp As Shape Set myrng = Application.Caller URL = "https://quickchart.io/qr?size=100&text=" & mytext On Error Resume Next ActiveSheet.Pictures("myqr" & myrng.Address(False, False)).Delete ActiveSheet.Pictures.Insert(URL).Select Set myshp = Selection.ShapeRange.Item(1) myshp.Placement = xlMoveAndSize With myshp .LockAspectRatio = msoFalse .Name = "myqr" & myrng.Address(False, False) .Left = myrng.Left .Top = myrng.Top End With masqr = "" End Function وطريقة استخدامها =masqr(A2) بالتوفيق

السلام عليكم نبدأ بها جرب الكود التالي Sub Test() Dim ws As Worksheet, sh As Worksheet, sTarget As String, lr As Long, m As Long, iRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("اذن") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then MsgBox "No Data", vbExclamation: Exit Sub Select Case ws.Range("C2").Value Case "اذن صرف": sTarget = "صرف" Case "اذن اضافه": sTarget = "اضافه" Case Else: MsgBox "No Such Worksheet", vbExclamation: Exit Sub End Select Set sh = ThisWorkbook.Worksheets(sTarget) m = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1 For iRow = 6 To lr sh.Range("A" & m).Resize(, 6).Value = Array(sh.Range("A" & m).Row - 2, ws.Range("E2").Value, ws.Range("C4").Value, ws.Range("C3").Value, ws.Cells(iRow, 1).Value, ws.Cells(iRow, 2).Value) sh.Range("I" & m).Value = ws.Cells(iRow, 4).Value If sh.Name = "اضافه" Then sh.Range("J" & m).Value = ws.Cells(iRow, 5).Value End If m = m + 1 Next iRow Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

وعليكم السلام- باركود IDAutomationHC39M Idautomationhc39m.zip

هذه مجموعة من الخطوط يمكنك تحميلها وتثبيتها في ويندوز واستعمالها في الاكسل أو الاكسس أو اي برنامج من برامج ميكروسوفت Code 128 Code 39 UPC-E QR Postnet UPC/ EAN I2of5 Intelligent Mail بالتوفيق

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

وعليكم السلام ورحمة الله تعالى وبركاته للأسف اخي الملف غير منظم نهائيا يصعب التعامل معه .!!! او فهمه( بالنسبة لي ) الأقل حاول وضع أسماء التلاميذ والتواريخ مع درجاتهم في جدول واحد لنتمكن من استخراج النتيجة بشكل صحيح . والله أعلم.

هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb

تفضل أخي الكريم Sub test() Dim a, w, x, k Dim i&, ii& a = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 5 To UBound(a) If Not .exists(a(i, 9)) Then .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), a(i, 10) & " NO - " & Format(a(i, 7), "0#")) Else w = .Item(a(i, 9)) x = Split(w(3), "-") If UBound(x) > 0 Then w(3) = x(0) & "- " & Format(a(i, 6), "0#") .Item(a(i, 9)) = w Else x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#") w(3) = Join(x) .Item(a(i, 9)) = w End If: End If Next For Each k In .keys Cells(5 + ii, 14).Resize(5) = Application.Transpose(.Item(k)) ii = ii + 6 Next End With End Sub

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

جرب التعديل والاستفادة من هذا الملف 05. Advanced Filter VBA 02 END.xlsm

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة البحث بين تاريخين تم ارفاق كود الحل من الفاضل _ أ/ رحمه الله الحسامي _ و أ / عبدالله باقشير و لا تنسونا من صالح الدعاء تحياتى find date (HOSSAMI).rar find date1 (KH).rar find date2 (KH NEXT).rar

السلام عليكم ورحمة الله وبركاته إخواني الأحباب في المنتدى المحبب إلى قلوبنا .. أقدم لكم اليوم شرح فيديو ، لكيفية عمل تصفية متقدمة Advanced Filter بالأكواد .. . والشرح مقدم في عدد 2 فيديو .. الأول لكيفية إدراج موديول وكتابة الأسطر الخاصة بتنفيذ التصفية المتقدمة ، والفيديو الثاني لكيفية تنفيذ الكود بدون أزرار بمجرد التغير في ورقة العمل أو التغير في شروط التصفية .. رابط الفيديو الأول : التصفية المتقدمة بالأكواد رابط الفيديو الثاني ومرفق لكم ملفين ..الملف الأول Advanced Filter VBA خاص بالفيديو الأول ، والملف المسمى Advanced Filter Worksheet_Change خاص بالفيديو الثاني أرجو أن ينال الدرس إعجابكم ، وتستفيدوا منه ولا أنتظر منكم سوى دعوة بظهر الغيب ، وادعوا الله لي أن يجعل أعمالنا صالحة ولوجهه خالصة ، وأن يجعل أعمالنا في ميزان حسناتنا يوم القيامة ، إنه ولي ذلك والقادر عليه كان معكم أخوكم أبو البراء من منتدى أوفيسنا (دي القفلة بتاعتي لو تلاحظوا .. مش شعبان عبد الرحيم بس اللي عنده القفلة !) حمل الملف من هنا

أخي الحبيب أبو يوسف بارك الله فيك وجزاك الله كل خير على مبادرتك الطيبة ، ويعجبني أنك تجتهد حتى وإن فشلت ، فأنا أسعد بالمجتهد حتى ولو فشل آلاف المرات ... أخي الغالي سعد عابد أسئلة كثيرة .................. ولكن لعيون سعد (سعد سعد يحيا سعد) الفرق بين Value و Value2 لن أجيبك بشكل نظري بحت ولكن اعلم أن التاريخ يكتب في خلية ويظهر لك بشكل مختلف عن الشكل الأصلي الذي يقرأه الإكسيل اكتب أي تاريخ في الخلية A1 .... روح لمحرر الأكواد واضغط Ctrl + G عشان تفتح النافذة الفورية (يوجد موضوع لها في حلقات افتح الباب) ... في النافذة الفورية اكتب هذين السطرين (أنا قلت اكتب ولم أقل انسخ والصق ..بطل كسل) ?range("A1").Value ?range("A1").Value2 ولاحظ النتائج بنفسك السؤال الثاني هو الكلمة Redim وهي لإعادة تشكيل المصفوفة من حيث الأبعاد فوضعت هنا لكي أجعلها نفس أبعاد المصفوفة الأولى المسماة Arr .. السؤال الثالث لإضافة شروط .... الموضوع بسيط شايف السطر ده اللي فيه IF ..... If Arr(I, 1) >= startDate And Arr(I, 1) <= endDate Then قبل كلمة Then يمكن إضافة الشروط باستخدام كلمة AND ثم تضيف الشرط المطلوب .. ويمكن إضافة أكثر من شرط لا مشكلة في ذلك على الإطلاق أما بخصوص آلية الكود فهو يقوم بوضع قيم النطاق في مصفوفة ثم إنشاء مصفوفة أخرى لوضع النتائج المتوافقة مع الشروط الموضوعة وفي نهاية المطاف في آخر سطر يتم التعامل مع الإكسيل بوضع النتائج التي في المصفوفة Temp ووضعها في الخلية L10 أرجو أن تكون الإجابات قد أدت الغرض وأخيراً إليك شرح الكود في الموديول الثاني في الملف المرفق حمل الملف من هنا وتقبلوا وافر تقديري واحترامي

جزاك الله خيرا وبارك فيك تقبل تحياتي وشكري

تم حل مشكلة التاريخ مع التصفية المتقدمة suppliers required 4.rar

بارك الله لك أخي محمد يحياوي وأثناء بحثي على الإنترنت كنت قد وجدت هذا الملف بخصوص التحكم في النموذج وبه الكثير من الدوال: منها عرض وإخفاء أزرار الغلق والتكبير والتصغير وشفافية النموذج وإمكانية تحجيمه و ..... و ..... و ...... أترككم مع المرفق الذي يجعل نماذجكم قمة في الروعة UserFormControl.rar

الاخ الحبيب "الحسامي" اشكرك جزيل الشكر على كبير كرمك و سعة صدرك و هذا الجزء الاول و الجزء الثاني من فهرس الموضوع الجزء 1 من فهرس موضوع الاكواد المنفصة.rar الجزء 2 من فهرس موضوع الاكواد المنفصة.rar