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

وعليكم السلام ورحمة الله وبركاته بعد اذن الاستاذ حجازى واثراءا للموضوع واظافة وهي عدم السماح للصف الذي به بيانات باظافة صف فارغ الا مرة واحدة الكود Private Sub CommandButton1_Click() Dim i As Long Dim ws As Worksheet Dim lastRow As Long Dim nextRowData As Long Set ws = ActiveSheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False lastRow = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ SearchFormat:=False).Row For i = lastRow To 2 Step -1 If Application.WorksheetFunction.CountA(ws.Rows(i)) > 0 Then nextRowData = Application.WorksheetFunction.CountA(ws.Rows(i + 1)) If nextRowData > 0 Then ws.Rows(i + 1).Insert Shift:=xlDown End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub الملف إضافة صف فارغ.xlsm

و عليكم السلام و رحمة الله و بركاته تفضل أخي الكريم Sub InsertBlankRowForAllColumns() Dim lastRow As Long Dim lastColumn As Long Dim i As Long, j As Long ' تحديد آخر صف وآخر عمود يحتويان على بيانات lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastColumn = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' البدء من آخر صف والعمل إلى الأعلى For i = lastRow To 2 Step -1 ' التحقق من وجود بيانات في أي من الأعمدة For j = 1 To lastColumn If Cells(i, j).Value <> "" Then Rows(i + 1).Insert Shift:=xlDown Exit For ' الخروج من الحلقة الداخلية إذا وجدنا بيانات End If Next j Next i End Sub إضافة صف.xlsm

@AmirMohamed ماشاء الله عمل رائع مع وافر الشكر والتقدير لشخصكم الكريم واداره المنتدى

تم التعديل وشرح االأسباب OK شرح الاسباب.xlsx

اتمني اكون سددت المطلوب Sub DeleteRows() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") Dim response As VbMsgBoxResult response = MsgBox("هل أنت متأكد أنك تريد نقل البيانات وحذفها من الجدول الأساسي؟", vbYesNo + vbQuestion, "تنبيه") If response = vbNo Then Exit Sub End If Dim lastRow As Long Dim lastRow1 As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row lastRow1 = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ws.Range("F3:J" & lastRow1).Clear ws.Range("A2:D" & lastRow).Copy ws.Range("G2").PasteSpecial Paste:=xlPasteAll ws.Range("A3:D" & lastRow).Clear ws.Range("F1:J1").Merge ws.Range("F1").Value = ws.Cells(1, 1).Value ws.Range("F1").NumberFormat = "dddd dd - mm - yyyy" With ws.Range("F1") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .Interior.Color = RGB(217, 217, 217) End With With ws.Range("F2:J2") .Interior.Color = RGB(217, 217, 217) .Font.Size = 16 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With With ws.Range("G3:J" & lastRow) .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ws.Cells(2, "F").Value = "ت" Dim i As Long For i = 3 To lastRow ws.Cells(i, "F").Value = i - 2 Next i ws.Range("F2:F" & lastRow).Borders.LineStyle = xlContinuous ws.Range("F2:F" & lastRow).HorizontalAlignment = xlCenter ws.Range("F2:F" & lastRow).VerticalAlignment = xlCenter ws.Columns("F").ColumnWidth = 6 ws.Columns("G").ColumnWidth = 16.88 ws.Columns("H").ColumnWidth = 19.68 ws.Columns("I").ColumnWidth = 19.38 ws.Columns("J").ColumnWidth = 8.5 Application.CutCopyMode = False ws.Cells(1, 1).Value = ws.Cells(1, 1).Value + 1 End Sub عمل تنسيقات بعد الضغط على الزر.xlsm

تمام اخي الكريم تفضل وهذه المعادلة المستخدمة : =IF($C$2<>"";TRANSPOSE(IFERROR(INDEX(UNIQUE(FILTER($B:$B; $A:$A = $C$2)); ROUNDUP(COLUMN(A1)/2; 0)); ""));"") HHA (1).xlsx

نعم لديك كل الحق نم التعديل في المشاركة السابقة

يوجد مكتبه مفقوده اخي غير مفعله

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

وعليكم السلام ورحمة الله وبركاته معلمنا العود ، عدت والعود أحمد 😊🌹🌼 بل خسارتنا أحنا أكبر لما تغيب عنا ونفتقد توجيهاتك وخبراتك 😅🖐

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

السلام عليكم أخي @gavan 🙂 ما اسم الجدول المستهدف؟ وما اسم الحقل المراد جمعه ؟ وهل هناك شروط أخرى للجمع غير أن التاريخ يجب أن يكون قبل التاريخ المعطى ؟ ولو تكرمت أضف المزيد من السجلات للتأكد من سلامة التطبيق .. لا يمكن التحقق من سلامة النتيجة ب 3 مدخلات فقط !!

المشكلة في الفراغات وبما ان الترقيم به ارقام ونصوص فيكون التنسيق نص كما تم وضع كود لازالة الفراغات الدالة =IFERROR(VLOOKUP(P5; 'صفحه البيانات'!$E$2:$F$10000; 2; FALSE); "غير موجود") الملف شرح الاسباب (1).xlsx

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

الكود في الملف مكتوب لنواة ويندوز مختلفة مثلا 32بت والنسخة الحالية 64بت وإذا كان لك صلاحية الدخول على الكود يمكنك وضع كلمة ptrsafe قبل اسم الدالة أو الإجراء مثل هذا الكود #If VBA7 Then Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr #Else Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long #End If بالتوفيق

تفضل اخي الحبيب وهذه المعادلة المستخدمة : =IF(B3<>""; SUBTOTAL(3; $B$2:B3); "") اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له box (1).xlsm

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

تفضل تعديلات جوهرية 1- اختصار 3 نماذج الى نموذج واحد ( الوارد / الصادر / التلفيات ) من اجل سهولة التعديل والتطوير .. حيث يكون العمل من مكان واحد 2- عملت ضوابط في النموذج حسب نوع العملية .. لزيادة التحكم 3- فك ارتباط النماذج بالجداول ، وادخال البيانات عبر مجموعة السجلات .. ونكسب من هذه الطريقة : A- منع الحفظ التلقائي B- عدم الحاجة لعمليات الحذف ( اما الحفظ واما الخروج وعدم الحفظ ) stock12 .rar

وعليكم السلام ورحمة الله وبركاته حسب فهمي لطلبك الكود Sub FilterAndCopyData() Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, wsDest As Worksheet Dim searchValue As String Dim rng As Range, cell As Range Dim lastRow As Long, destRow As Long Dim serialNumber As Long Set ws1 = ThisWorkbook.Sheets("SHEET1") Set ws2 = ThisWorkbook.Sheets("SHEET2") Set ws3 = ThisWorkbook.Sheets("SHEET3") Set wsDest = ThisWorkbook.Sheets("SAAD") wsDest.Range("C13:R" & wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row).ClearContents searchValue = wsDest.Range("N7").Value destRow = 13 serialNumber = 1 For Each ws In Array(ws1, ws2, ws3) lastRow = ws.Cells(ws.Rows.Count, "P").End(xlUp).Row Set rng = ws.Range("P12:P" & lastRow) For Each cell In rng.Cells If cell.Value = searchValue Then wsDest.Cells(destRow, "C").Value = serialNumber wsDest.Cells(destRow, "F").Value = cell.Offset(0, -10).Value wsDest.Cells(destRow, "J").Value = cell.Offset(0, -6).Value wsDest.Cells(destRow, "L").Value = cell.Offset(0, -4).Value wsDest.Cells(destRow, "M").Value = cell.Offset(0, -3).Value wsDest.Cells(destRow, "P").Value = cell.Value wsDest.Cells(destRow, "Q").Value = cell.Offset(0, 1).Value wsDest.Cells(destRow, "R").Value = cell.Offset(0, 2).Value destRow = destRow + 1 serialNumber = serialNumber + 1 End If Next cell Next ws End Sub الملف ترحيل الدرجات1.xlsm

أنت البحر بأمواجه أستاذنا العزيز @ابوخليل 🙂 🌹 والعسل لا ينطق إلا كلام كالعسل يا عسل 🙂 🌷 روعتها من روعتكم 😊🌷

تفضل stock11 .rar

بالنسبة للحفظ والحذف اكسس يحفظ آليا بدون أمر .. بمجرد الكتابة اما الحذف فأرى ان يتم الحذف من نموذج التعديل ,, لأن البيانات ستكون ظاهرة فيه الرئيسي اعمل له زر ماكرو .... والفرعي جاهز فقط يتم التحديد على السجل ثم زر delet ---------------------------------- اعجبني مثالك .. اذا وجدت الوقت الكافي سوف اعمل تحسينات جوهرية عليه ----------------------------------------------- تفضل هذه طريقة الترقيم الخاص Dim xLast, xNext As Integer Dim prtyr, prtTxt As Integer xLast = DMax("moveCode", "tblInvoiceHeader", "Left(moveCode, 1) ='" & "W" & "'") prtyr = Left(xLast, 1) If IsNull(xLast) Then xNext = 1 prtyr = "W" Else xNext = Val(Mid(xLast, 2, 5)) + 1 End If Me!moveCode = prtyr & Format(xNext, "00000") stock10 .rar

عليكم السلام اخي الكريم .. توجيه الطلب لشخص بعينه غير مستحسن ، ولا يصب في صالح السائل .. فقد يحرمه من اجابات افضل .. لطفا .. لا تكررها .. واجعل طلبك دوما للعموم -------------------------- مطلوبك سهل جدا ويمكن تحقيقه بعدة طرق منها : 1- ان يكون الرقم = id ... في حدث بعد التحديث لمربع العميل : moveCode=id بكذا يكون غير قابل للتكرار وكل فاتورة لها رقمها الخاص بعضهم يريد التنسيق التالي : تسلسل ارقام الوارد لوحدها وتمييزها بحرف .. وكذلك تسلسل ارقام الصادر لوحدها وتمييزها بحرف انظر ماذا تريد

قم بتغيير الكود الى هذا Private Sub Worksheet_SelectionChange(ByVal Target As Range) ActiveSheet.Unprotect '================== For Each cel In Target.Cells Application.EnableEvents = False If cel.HasFormula Then cel.Locked = True cel.FormulaHidden = True With ActiveSheet .Protect .EnableSelection = xllockedCells End With GoTo 1: Else ActiveSheet.Unprotect End If Next 1: Application.EnableEvents = True End Sub

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

السّلام عليكم و رحمة الله و بركاته جزاكم الله خيرًا أساتذتي و إخواني الأكارم فقط لإكمال الملف بزر الخروج مثلما ذكره الأستاذ القدير مختار حسين محمود ..مع تعديلات طفيفة فائق إحتراماتي الشيت السري 3.rar

انسخ هذا الكود الى حدث الصفحة و اعطني رأيك Private Sub Worksheet_SelectionChange(ByVal Target As Range) '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Application.ScreenUpdating = False If Target.HasFormula = True Then Application.DisplayFormulaBar = False ActiveSheet.Protect Application.ScreenUpdating = True Exit Sub Else Application.DisplayFormulaBar = True ActiveSheet.Unprotect End If Application.ScreenUpdating = True End Sub

الأخ الحبيب ياسر جرب الملف التالي ... بحماية الورقة Restrict Cursor Movement To Unprotected Cells.rar

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

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

استعمل هذا الكود Private Sub Worksheet_Selectionchange(ByVal Target As Range) Range("C5").Formula = "=SUM(A:A)" End Sub