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

Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False Irow = wsPass.Cells(wsPass.Rows.Count, "G").End(xlUp).Row For j = 4 To Irow Step 2 wsPass.Range("A" & j & ":N" & j).ClearContents Next j lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 End If Next i Application.ScreenUpdating = True End Sub test.xlsb

ولماذا تعطي لنفسك افضل اجابة ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

مشكووووووووووووووووووور صديقي كل الشكر

من وجهة نظري .. أيضاً اتبع فكرة قديمة وهي :- 1. أنشئ مربع نص باسم C1 مثلاُ . 2. في حدث عند الشوائب اجعل قيمته = 0 Private Sub Form_Dirty(Cancel As Integer) Me.C1 = 0 End Sub 3. في حدث عند الإغلاق أو إذا كان لدي زر خاص بالإغلاق للنموذج DoCmd.CancelEvent If Me.C1 = 0 Then Me.Undo End If بالنسبة لي هذا يمنع الحفظ التلقائي للسجلات الغير مكتملة أولاً ، ثم يجعلني أتحكم في - متى أحفظ أو لا - السجلات في النموذج .

أصل هذه الشفرة في المشاركة التالية

في مشاركتك الأولى ، أهلا وسهلاً بك معنا أخي الكريم @mhm55 . ونتمنى أن تجد ما تبحث عنه من فائدة ومعلومة ونصيحة اسمح لي أولا بلفت انتباهك إلى ضرورة التقيد بـ قوانين المنتدى ، حتى تصل إلى مطلوبك بشكل سريع و واضح . ومن هذه الأمور التي عليك الإلتزام بها :0 1. ضرورة الإيضاح في طلبك بشكل كافي و شافي و وافي . 2. ارفاق ملف لتوضيح الصورة إن لزم الأمر . 3. لوضع كود في المشاركة ، استخدم علامتي التكويد <> ثم لصق الكود ليكون سهلاً في القراءة ؛ كما سترى لاحقاً . أما بالنسبة لطلبك ومشكلتك ،، عليك أولا التأكد من أمرين مهمين هما :- 1. تأكد أن ملف الإكسيل موجود في المسار المحدد في الكود (CurrentProject.Path & "\ITEMX.xlsx") 2. تأكد أن اسم ورقة العمل في ملف الإكسيل هو فعلاً = "SHEET1$" . إذا كان الاسم مختلفاً ، قم بتعديله في الكود . 3. جملة الإستعلام في الكود الذي ارسلته غير صحيحة في آكسيس ، والتالي تعديل عله يكون صحيحاً * بعد تجربة الكود على ملف سابق كما أشار معلمنا @أبو إبراهيم الغامدي ، تبين ان الكود الأصلي في مشاركتك يعمل بدون أي مشاكل . والجملة 3 أعلاه أصبحت بعد لتجربة غير صحيحة أشكر معلمنا الفاضل للفت انتباهي

وعليكم السلام ورحمة الله وبركاته ضف هذا السطر للكود wsSource.Cells(i, 1).Resize(1, 14).ClearContents الكود كاملا Sub test() Dim wsSource As Worksheet Dim wsPass As Worksheet Dim lastRow As Long Dim i As Long Dim passRow As Long Dim passCount As Long Dim failRow As Long Dim wsFail As Worksheet Set wsSource = ThisWorkbook.Sheets("Sheet1") Set wsPass = ThisWorkbook.Sheets("Sheet2") lastRow = wsSource.Cells(wsSource.Rows.Count, "a").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "g").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق wsSource.Cells(i, 1).Resize(1, 14).ClearContents passRow = passRow + 2 End If Next i End Sub

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا مما تحاول فعله جرب هدا Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long, Rng As Range Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 If Rng Is Nothing Then Set Rng = wsSource.Cells(i, 1).Resize(1, 14) If Not Rng Is Nothing Then Set Rng = Union(Rng, wsSource.Cells(i, 1).Resize(1, 14)) End If Next i If Not Rng Is Nothing Then Rng.ClearContents Application.ScreenUpdating = True End Sub لحدف الصفوف If Not Rng Is Nothing Then Rng.Delete Shift:=xlUp End If

وعليكم السلام ورحمة الله تعالى وبركاته لتحديد حجم كل منتج مع لونه يمكنك استخدام الصيغة التالية =SUMPRODUCT(($B$2:$B$8=$B11)*($C$2:$C$8=C$10)*($D$2:$J$8)) مع سحبها يسارا والى للاسفل على حسب احتياجاتك مجرد اقتراح يمكنك أيضا استخراج مجموع كل آلة بشكل منفصل حسب اختيارك للحصول على مزيد من التفاصيل وعند اختيار الخيار "الكل" سيتم عرض مجموع جميع الآلات يمكن القيام بذلك باستخدام الصيغة التالية بعد إضافة قائمة منسدلة تحتوي على أسماء رؤوس الأعمدة الموجودة في الجدول =IF($O$10="الكل", SUMPRODUCT(($B$2:$B$8=$M12)*($C$2:$C$8=N$11)*($D$2:$J$8)), IFERROR(SUMIFS(INDEX($D$2:$J$8, 0, MATCH($O$10, $D$1:$J$1, 0)), $B$2:$B$8, $M12, $C$2:$C$8, N$11), 0)) هدا سيمكنك من استخراج النتائج بعدة طرق يمكنك اختيار ما يناسبك زيرو 2.xlsx

السلام عليكم حفظ الصورة + غرض البيانات الخطوات زر تفريغ البيانات تعبئة البيانات ورقم القيد اجباري زر اظافة ومدمج معه تحميل الصورة ويمكن تحميل الصورة من اي ملف على جهاز الكمبيوتر عرض البيانات - البحث بالقيد او بالاسم مع استدعاء الصورة انتهي الملف المنظومة11.xlsm

تم التعديل إنشى فولدر photos لوضع الصور كود الموظف J2 إظهار الصورة فى Q17 كود Function فى AA2 ok المنظومة.xlsm

أهلا بك.. نعم.. الشفرة التالية تقوم بالتحديث والإدراج معاً! Sub UPDATE_FROM_EXCEL() '-- GET EXCEL FILE Dim XL_FILE As String XL_FILE = CurrentProject.Path & "\ITEMX.xlsx" '-- WRITE SQL STATEMENT Dim SQL As String SQL = SQL & "UPDATE TABLE1 AS T1 " SQL = SQL & "RIGHT JOIN " SQL = SQL & "(SELECT * FROM [SHEET1$] IN'" & XL_FILE & "'" SQL = SQL & "[EXCEL 12.0;HDR=YES;IMEX=1;]) AS T2 " SQL = SQL & "ON T1.[كود_الصنف] = T2.[كود الصنف] " SQL = SQL & "SET T1.[كود_الصنف] = T2.[كود الصنف]," SQL = SQL & "T1.[اسم_الصنف] = T2.[اسم الصنف]" '-- RUN SQL STATEMENT CurrentDb.Execute SQL End Sub ITEMX.accdb ITEMX.xlsx