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

السلام عليكم ورحمة الله وبركاتة برنامج القران الكريم والتفسير والبحث في القران الكريم هديه بقرب شهر رمضان المبارك كل عام وانتم بخير البرنامج مفتوح المصدر (( ان هاذا العمل ليس من عملي بل هو تجميع من شباب هاذا المنتدى الرائع ولا انسب هاذا العمل الي ابدا بل هو من فاعلين خير جزاهم الله كل خير ارجو منكم دعوه صالحة لي ولهم ولكل المسلمين )) http://www.mediafire.com/file/o0hvlo44krko53d/%D8%A8%D8%B1%D9%86%D8%A7%D9%85%D8%AC_%D8%A7%D9%84%D9%82%D8%B1%D8%A3%D9%86_%D8%A7%D9%84%D9%83%D8%B1%D9%8A%D9%85.rar/file

جرب هذا الكود Option Explicit Sub copy_data() Dim my_rg As Range Dim col#, x# Set my_rg = Sheets("sheet1").Range("b2", Range("b3").End(4)) col = Sheet2.Rows(2).Find(vbNullString, after:=Cells(2, Columns.Count) _ , SearchDirection:=1).Column If col > 1 Then x = Application.CountIf(Sheet2.Rows(2), "<>" & "") * 2 - 1 col = Sheet2.Rows(2).Find(vbNullString, after:=Cells(2, x), _ SearchDirection:=1).Column + 1 End If Sheet2.Cells(2, col).Resize(my_rg.Rows.Count, 1).Value = my_rg.Value End Sub الملف مرفق salim_test.xlsm

بسم الله الرحمن الرحيم الاخوة الكرام السلام عليكم ورحمة الله وبركاته وجدت مثال لعملية فرز البيانات في التقرير والمثال رائع جداً يوجد تقرير باسم rptStudentInformation عند الفتح يتم نموذج frmOrderBy وبه عدة خيارات للفرز ما اريده ان استخدام نموذج frmOrderBy في اكثر من تقرير ولكن الكود الموجود مرتبط بتقرير محدد If strSQL <> "" Then 'Strip Last Comma & Space strSQL = left(strSQL, (Len(strSQL) - 2)) 'Set the OrderBy property Reports![rptStudentInformation].OrderBy = strSQL Reports![rptStudentInformation].OrderByOn = True Else Reports![rptStudentInformation].OrderByOn = False End If فهل بالامكان تعديل الكود للعمل مع التقرير الحالي بغض النظر عن اسمه Sort.rar تحياتي

تم التعديل اكثر وأكثر ليبدو الامر أكثر وضوحاً Option Explicit Sub Salim_filter1() With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("A2:J" & Rows.Count).Clear .Range("k:k").Clear End With Dim x% Dim i As Byte, D%: D = 1 Dim y%, k%: k = 1 Dim xx%, m% Dim t1%, t2% For m = 1 To Worksheets.Count With Sheets(m) If .Name <> "SALIM_BALANCE" Then x = Application.Max(.Range("a:a")) + 1 y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row Sheets("SALIM_BALANCE").Range("B" & D + 1).Resize(x - 1, 9).Value = _ .Range("b2").Resize(x, 9).Value t1 = D + 1 With Sheets("SALIM_BALANCE") With .Cells(D + 1, "K") .Value = "BEGIN OF SHEET: " & Sheets(m).Name .Interior.ColorIndex = 20 D = D + x - 1 t2 = D End With .Cells(t2, "K") = "END OF SHEET: " & Sheets(m).Name .Cells(t2, "K").Interior.ColorIndex = 44 .Cells(t2 + 1, "H").Formula = "=SUM(H" & t1 & ":H" & t2 & ")" .Cells(t2 + 1, "J").Formula = "=SUM(J" & t1 & ":J" & t2 & ")" .Cells(t2 + 1, 1).Resize(, 11).Interior.ColorIndex = 35 .Cells(t2 + 1, "K") = "SUMMATION Of SHEET " & Sheets(m).Name D = D + 1 End With End If End With Next With Sheets("SALIM_BALANCE") xx = .Cells(Rows.Count, "b").End(3).Row For i = 2 To xx If .Range("A" & i).Interior.ColorIndex <> 35 Then .Range("A" & i) = k k = k + 1 Else k = 1 End If Next With .Range("A2:K" & xx + 1) .Borders.LineStyle = xlContinuous .Font.Bold = True .InsertIndent 1 End With .Range("B2:B" & xx).NumberFormat = "d/m/yyyy" End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub الملف الجديد tartib _mars new_1.xlsm

تم معالجة الامر بالنسية للمعادلات في (سعر الطن)تم تصحيحها اختصرت البملف الى 3 صفحات مع عدد اقل من البيانات لمراقبة عمل الكود يمكن نقل الكود الى الملف الصحيح و تصحيح المعادلات هناك Option Explicit Sub Salim_filter1() 'On Error Resume Next With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("A2:J" & Rows.Count).Clear .Range("k:k").Clear End With Dim x As Integer, LAST_ROW Dim i As Byte, D%: D = 1 Dim y%, k%: k = 1 Dim xx% For i = 1 To Worksheets.Count With Sheets(i) If .Name <> "SALIM_BALANCE" Then x = Application.Max(.Range("a:a")) + 1 '========================== y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row '================ .Range("b2:J" & x).Copy Sheets("SALIM_BALANCE").Range("B" & D + 1) With Sheets("SALIM_BALANCE") With .Cells(D + 1, "K") .Value = "BEGIN OF SHEET: " & Sheets(i).Name .Interior.ColorIndex = 20 D = D + x - 1 End With .Cells(D, "K") = "END OF SHEET: " & Sheets(i).Name .Cells(D, "K").Interior.ColorIndex = 44 With .Cells(D + 1, 1).Resize(, 10) .Value = Sheets(i).Cells(y, 1).Resize(, 10).Value .NumberFormat = "General" .Interior.ColorIndex = 35 End With .Cells(D + 1, "K") = "SUM" D = D + 1 End With End If End With Next With Sheets("SALIM_BALANCE") xx = .Cells(Rows.Count, "b").End(3).Row For i = 2 To xx If .Range("A" & i).Interior.ColorIndex <> 35 Then .Range("A" & i) = k k = k + 1 Else k = 1 End If Next End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub الملف tartib _mars new.xlsm

أخي @صلاح جبر المشكلة تكمن في المكتبات قم بأدراج المكتبات

تطبيقات عملية للخصائص المتقدمة multipage control الفيديو الصور حمل الملف صفحات_متعددة.rar

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

جرب هذا الماكرو Sub Salim_filter() 'On Error Resume Next With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("B2:H" & Rows.Count).ClearContents .Range("k:k").Clear End With Dim x As Integer, LAST_ROW Dim i As Byte, D%: D = 1 For i = 1 To Worksheets.Count With Sheets(i) If .Name <> "SALIM_BALANCE" Then x = .Range("A" & Rows.Count).End(xlUp).Row .Range("b2:H" & x).Copy Sheets("SALIM_BALANCE").Range("B" & D + 1) With Sheets("SALIM_BALANCE") .Cells(D + 1, "K") = "BEGIN OF SHEET: " & .Name .Cells(D + 1, "K").Interior.ColorIndex = 35 D = D + x + 1 .Cells(D - 2, "K") = "END OF SHEET: " & .Name .Cells(D - 2, "K").Interior.ColorIndex = 44 End With End If End With Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub الملف مرفق tartib _mars.xlsm

جزاك الله كل خير

للرفع ارجو من كان لدية الحل فلا يبخل 🙂

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

فورم حركة سير للسواقين والاداريين والانتداب والعمل الخفيف الفيديو الصور الملف استعلام عن السواقين والاداريين بالشركةxls.rar

نعم هذا الشيء يسرع الماكرو بشكل كبير اليك هذه التجربة في هذا الملف MACRO_SPEED.xlsm

مثال .. اخر .. اتمنى ان ينال اعجابكم .. ممكن الاستفادة منه .. نضع بيانات الطلبة في صفحة data .. ادخال الغياب اليومي في صفحة datastudent .. بعد الانتهاء من الادخال يتم حفظ البيانات عن طريق الزر الموجود في اعلى الصفحة اما ورقة datasave .. يتم من خلالها حفظ البيانات السابقة التي تم حفظها .. اما ورقة repstudent .. تقرير غياب واستئذان وتأخر الطالب .. تم وضع رزنامة خلال العام الدراسي .. يتم تظليل أيام الغياب .. من خلال زر تحديث .. بعد ادخال رقم الطالب لجلب بياناته .. اما ورقة datasearch .. ممكن من خلاله البحث حسب التاريخ من و الى .. مع احتساب الاجازات في الخلية m2 .. reapstudent.xlsm

عسى يكون المطلوب stu.accdb

السلام عليكم ورحمة الله وبركاته اشكرك استاذي عند فتح البرنامج تظهر الرسائل التالية ولا يعمل البرنامج salehm79@gmail.com

قم بتمكين الماكرو وسيعمل معك ان شاء الله

مشكور أستاز سيد على تعبك على فكره أنا بكتب الأس والباسورد بس مبيفتحش ليه mared الباس ورد 123 صح كدا

اخى جعفر منور المشاركه بارك الله فيك ............................................. اخى محمد كما قال اخونا عبد العزيز الكود يعمل بنجاح ولكن جرب كود اخانا جعفر تقبلو تحياتى

لا تستعمل Application.InputBox افضل استعمال vba.InputBox Private Sub CommandButton1_Click() Unload Me End Sub Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Dim rng As Range, LR As Long Dim x x = InputBox("Please enter a Quntity") If x = False Or StrPtr(x) = 0 Or Not IsNumeric(x) Then Exit Sub Else LR = Sheets("invoice").Cells(Rows.Count, "E").End(xlUp).Row + 1 Set rng = Sheets("invoice").Cells(LR, 4) If ListBox1.Value <> "" Then rng.Value = ListBox1.Value rng.Offset(0, 1).Value = ListBox1.List(ListBox1.ListIndex, 1) rng.Offset(0, 4).Value = ListBox1.List(ListBox1.ListIndex, 2) rng.Offset(0, 2).Value = x End If End If End If End Sub Private Sub TextBox1_Change() Dim LR As Integer, R As Integer, T As Integer ListBox1.Clear With Sheets("Codes") LR = .Cells(.Rows.Count, 2).End(xlUp).Row For R = 2 To LR If .Cells(R, 2) Like "*" & TextBox1.Text & "*" Then ListBox1.AddItem ListBox1.List(T, 0) = .Cells(R, 1) ListBox1.List(T, 1) = .Cells(R, 2) ListBox1.List(T, 2) = .Cells(R, 4) ListBox1.List(T, 3) = .Cells(R, 5) T = T + 1 End If Next End With End Sub Private Sub UserForm_Activate() TextBox1_Change ListBox1.ListIndex = 0 End Sub