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

بعد اذن استاذنا الرائد طبعا .... على الرغم اننا نبهنا مرارا وتكرارا ان لا وجود لأى مشاركة الا بإحتوائها على ملف مدعوم بشرح كافى عن المطلوب , فغير ذلك مخالف لقوانين المنتدى وسيعرض المشاركة للحذف حيث انه يعمل على اهدار وقت الأساتذة دون جدوى كما انه لا يمكن العمل على التخمين,على الرغم من كل هذا قمت بعمل ملف لك بالمطلوب .... فعليك من البداية فتح مديول جديد ووضع هذا الكود به Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Public Const VK_SNAPSHOT = 44 Public Const VK_LMENU = 164 Public Const KEYEVENTF_KEYUP = 2 Public Const KEYEVENTF_EXTENDEDKEY = 1 وبعد تصميم الفورم عليك بوضع هذا الكود به للطباعة Private Sub CommandButton1_Click() DoEvents keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + _ KEYEVENTF_KEYUP, 0 keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + _ KEYEVENTF_KEYUP, 0 DoEvents Workbooks.Add Application.Wait Now + TimeValue("00:00:01") ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, _ DisplayAsIcon:=False ActiveSheet.Range("A1").Select With ActiveSheet.PageSetup .Orientation = xlPortrait .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With ActiveWindow.SelectedSheets.PrintOut Copies:=1 ActiveWorkbook.Close False End Sub وهذا هو الملف print Userform.xlsm

وعليكم السلام-تفضل حسابات المعرض1.xlsx

شكر وتقدير واحترام استاذ على واستاذ سليم ابداع والله ماشاء الله

ألملف بواسطة الماكرو Option Explicit Sub Repeat_by_choise() Dim i%, K%, lr%, m%, Mot$ Mot = "النتيجه المطلوبه" With Sheets("ورقة1") .Range("k1").CurrentRegion.ClearContents .Range("k1") = Mot lr = .Cells(Rows.Count, 1).End(3).Row K = IIf(Val(.Cells(2, 3)) <= 0, 2, Int(.Cells(2, 3))) .Cells(2, 3) = K m = 2 For i = 2 To lr .Cells(m, "K").Resize(K).Value = _ .Cells(i, 1).Value m = m + K Next End With End Sub Repeat _by_choise.xlsm

يمكنك استخدام معادلة المصفوفة ( Ctrl+Shift+Enter) .... من أعمال استاذنا سليم حاصبيا له منا كل المحبة والإحترام =IFERROR(IF(ROW($C$2)>SUM($C$2),"",INDEX($A$2:$A$100,MATCH(FALSE, COUNTIF($E$1:E1,$A$2:$A$100)=$C$2,0))),"") 81.xlsx

جرب هذا الملف Option Explicit Sub Sort_me(ByVal rag As Range, ByVal col As Integer, Ad As Integer) rag.Sort key1:=rag.Cells(1, col), order1:=Ad, Header:=1 End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub ToggleButton1_Click() Dim My_col If (Selection.Address(0, 0) = "A1" Or _ Selection.Address(0, 0) = "B1" Or _ Selection.Address(0, 0) = "C1") And _ Selection.Count = 1 Then My_col = Selection.Cells(1, 1).Column If ToggleButton1 = True Then Call Sort_me(Selection.CurrentRegion, My_col, 2) ToggleButton1.Caption = "تنازلي حسب خلية " & Cells(1, My_col) Else Call Sort_me(Selection.CurrentRegion, My_col, 1) ToggleButton1.Caption = "تصاعدي حسب خلية " & Cells(1, My_col) End If Else Exit Sub End If End Sub الملف مرفق commendos_sort.xlsm

السلام عليكم .... في نموذج المختبر يوجد زر التراجع عن التسجيل المشكلة انة يقوم بحذف السجل الحالي بعد ادخال البيانات كيف اجعلة يقوم بالتراجع خطوة واحدة التراجع.accdb

أ / محمد صالح شكر وتقدير وخالص الدعاء لحضرتك فعلا الكود يعمل تمام سلمت يمينك بارك الله فيك احترامى اخيك

مشاركة مع الاخوان Up-1.accdb

Private Sub CommandButton1_Click() UserForm1.PrintForm End Sub

أستاذي الفاضل جربته وظهرت الرسالة

وعليكم السلام, لماذا لا تستخدم خاصية البحث بالمنتدى -تفضل تحويل الصف الى عمود والعكس تحويل الصف إلى عامود والعامود إلى .......... وهذا فيديو ايضاً للشرح طريقتان لتحويل الصفوف لأعمدة والأعمدة لصفوف Excel Training

مرحبا بك أستاذ @abouelhassan يمكنك استعمال الوسيطة الأولى sh والتي تعني كائن الشيت الحالي في الشرط ليصبح الكود كالتالي: Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name = "Sheet3" Then If Not Application.Intersect(Target, Range("a1:a1000")) Is Nothing Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True End If Else If Not Application.Intersect(Target, Range("a1:w1")) Is Nothing Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True End If End If End Sub لاحظ استعمال sheet3 وهو اسم الشيت المطلوب استثناؤه خالص دعواتي بالتوفيق

تفضل يمكنك هذا بعد مشاهدة هذا الفيديو

مشكور استاذ علي على هذه المغادلة لكن انت تعرفني اني لا أحب دالة IFERROR ولا استعملها الا في الحالات الضرورية حيث لا مفر منها لانها تجبر البرنامج على حساب المعادلة واذا كان هناك حطأ يضع فراغ (هذا شيء شرحته في مشاركات سابقة عديدة) لذلك اقترح هذا المعالة في العامود H مثلاً الخلية 2 : =IF(ROWS($H$2:H2)>$C$2*COUNTA($A$2:$A$100),"",INDEX($A$2:$A$100,MATCH(FALSE, COUNTIF($H$1:H1,$A$2:$A$100)=$C$2,0))) الملف مرفق Repeat _by_choise.xlsx

عند استخدام جهاز عربي انجليزي تظهر الرسالة التي اشار اليها الاخ بلال تحياتي وتقديري

ربنا يبارك فيك يا غالي شغل عالي استفسار هذا الكود يعمل مع اي ملف اي ل اعداد كثيرة من الاعمدة وجدت هذا الكود كيف يمكنني الاستفادة منه Sub SortTable() Dim myTable As Range Dim myColToSort As Long Dim curWks As Worksheet Dim mySortOrder As Long Dim LastRow As Long Dim iCol As Integer Dim strCol As String iCol = 170 '10 columns strCol = "A" ' column to check for last row Set curWks = ActiveSheet With curWks ActiveSheet.Unprotect myColToSort = .Shapes(Application.Caller).TopLeftCell.Column LastRow = .Cells(.Rows.Count, strCol).End(xlUp).Row Set myTable = .Range("a6:a" & LastRow).Resize(, iCol) If .Cells(myTable.Row + 1, myColToSort).Value _ < .Cells(LastRow, myColToSort).Value Then mySortOrder = xlDescending Else mySortOrder = xlAscending End If myTable.Sort Key1:=.Cells(myTable.Row, myColToSort), _ Order1:=mySortOrder, _ Header:=xlYes End With ActiveSheet.Protect End Sub اجعل وقت لغيرك فى طلب الإستفسار والمشاكل, طالما تحصلت على الإجابة المطلوبة

مرفق الملف، وبالتوفيق معادلة للبحث لاقرب قيمة اكبر من الراتب.xlsx

شكرا لك استاذنا المبدع

تفضل. اللانتقال التلقائي بمجرد الانتهاء من الرقم الرابع أو غير هدا السطر في الملف الأول من 6 الى 4 و يعمل 100/100 If TextBox1.TextLength = 4 Then OK UserForm TextBox MaxLength.xls

وعليكم السلام-الأمر ليس بهذه البساطة , عليك بتتبع الخطوات والإرشادات كما بفيديو الأستاذة ساجدة العزاوى , لها منا كل المعزة و الإحترام وبارك الله فيها كيفية اضافة و ريجستر month view-date and time picker اكسل vba ساجدة العزاوي register

عادة ما تتضمن نتائج التحاليل الاحصائية مصفوفة الارتباط التي تبين درجة الارتباط بين المتغيرات التي نجدها ممثلة فى رؤوس الأعمدة و الصفوف و تكون هذه المصفوفة صعبة القراءة اذا تركت دون تنقيح ، و أحد خطوات التنقيح المتعارف عليها هو مسح محتوى احد شطري المصفوفة لتكون اكثر وضوحا حيث ان الشطران يقدمات نفس المعلومة نماما فمعامل الارتباط بين س و ص = 0.5 يعني تماما ان معامل الارتباط بين ص و س = 0.5 و بالتالي وجود شطران للمصفوفة لا يضيف معلومة و بالطبع هناك من يحبذ ترك الشطرين ، و انا مع الرأي الأول لذا أعددت هذا الكود و للتوضيح هذا هو الوضع قبل حذف احد الشطرين و هذا بعد الحذف و للحصول على ذلك قم باختيار مساحة البيانات كاملة دون رؤوس الصفوف و الاعمدة و شغل الكود التالي Sub Correlation_Clear() ' ' delelte matrix upper half & also diagonal Application.ScreenUpdating = False Dim myrow As Long, origraw As Long Dim mycol As Long, oricol As Long myrow = Selection.Rows.Count origraw = myrow mycol = Selection.Columns.Count oricol = myrow ActiveCell.Select 'MsgBox MyRow For i = 0 To myrow For j = i + 1 To mycol ActiveCell.Offset(i, j) = "" Application.StatusBar = "Clearing ...." & _ Format(i / origraw, "0.0%") & " Please Wait......." Next j Next i For i = 0 To myrow - 1 With ActiveCell.Offset(i, i).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -4.99893185216834E-02 End With With ActiveCell.Offset(i, i) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With Next i Application.ScreenUpdating = True Application.StatusBar = False End Sub مرقق الملف للتجربة Clear-correlation.xlsm موضوع مرتبط يمكن الاستفادة منه فى الخطوة التالية للتجهيز و هي تحويل المصفوفة لجدول مقارن ، لمن أراد كود لتحويل مصفوفة إلى عمود واحد رأسي

السلام عليكم علي فرض أن البيانات موجودة بالعمود (A) جرب هذا الكود Sub Macro1() [A9999].End(xlUp).Offset(1, 0).Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Rows.Delete Shift:=xlUp [B1].Select ActiveWorkbook.Save End Sub

بارك الله فيك أخى الكريم إذا أردت عدم مسح البيانات و أردت إبقائها ؟ و ماذا لو أردت توسيع نطاق الترحيل ؟ عذرا" للسؤال فهو من مبتدىء