علي المصري

شكرا جزيلا

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

الكود التالي لنقل الاعمدة الموضح بالرقام من صفحة الى اخرى Sub Cycles() Dim a With Sheets("DataT1").Cells(1).CurrentRegion a = .Value With Sheets("CyclesT1") .Cells(1, 1).Resize(UBound(a), 31) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), [{1,2,4,6,7,8,9,10,11,12,13,14,15,16,17}]) End With: End With End Sub قمت بالتعديل على ارقام الاعمدة التي يراد نقلها كما هو موضح بالكود التالي Sub CyclesB1T1() Dim a With Sheets("B1DataT1").Cells(1).CurrentRegion a = .Value With Sheets("CyB1T1") .Cells(1, 1).Resize(UBound(a), 15) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), [{20,21,23,25,26,27,28,29,30,31,32,33,34,35,36}]) End With: End With End Sub مما ادى الى ظهور #REF عند التنفيذ ما الخطأ T1.xlsb

شكرا جزيلا وجزاكم الله خيرا ومعذرة على تعبكم

بعد عملية الترحيل اريد ترحيل بعض الاعمدة من هذه البيانات المجمعة في الصفحة DataT1 إلى صفحة جديدة اخرى اسمها مثلا GradesT1 فكيف يكون شكل الكود شكرا لكم

عند استخدام هذا الكود ظهر صف فارغ بين بيانات الصفة الاولى والثانية وهكذا تم التغلب عليه عن طريق التعديل التالي Sub Merge_Sheets() Dim Sht As Worksheet Dim Sht6 As Worksheet Dim LastRow6 As Long Dim Rng As Range Set Sht6 = Sheets("DataT1") 'Determine lastrow on DatatT1 x = Array("B1DataT1", "B2DataT1", "B3DataT1") 'Loop though B1DataT1 - B2DataT1 - B3DataT1 For i = 0 To UBound(x) Set Sht = Sheets(x(i)) 'Find last row LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row 'Set Range Set Rng = Sht.Range("A3:Q" & LastRow) LastRow6 = Sht6.Cells(Rows.Count, 1).End(xlUp).Row 'Copy to DataT1 If LastRow6 = 1 Then Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 2) Else Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 1) End If Next End Sub مع الشكر الجزيل لحضرتك

أولا شكرا لك وجزاك الله خيرا ثانيا ممكن شرح لهذا السطر من الكود

لا يعطي نتيجة

السلام عليكم ورحمة الله وبركاته الكود التالي المفروض يقوم بدمج الصفحات الثلاثة B3DataT1, B2DataT1, B1DataT1 الي الصفحة DataT1 ولكن لا يعمل بشكل صحيح فهل من مساعدة لتصحيحه Sub Merge_Sheets() Dim Sht As Worksheet Dim Sht6 As Worksheet Dim LastRow6 As Long Dim Rng As Range Set Sht6 = Sheets("DataT1") 'Determine lastrow on DatatT1 LastRow6 = Sht6.Range("A" & Rows.Count).End(xlUp).Row 'Loop though B1DataT1 - B2DataT1 - B3DataT1 For Each Sht In Sheets(Array("B1DataT1", "B2DataT1", "B3DataT1")) 'Find last row LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row 'Set Range Set Rng = Sht.Range("A3:Q" & LastRow) 'Copy to DataT1 Rng.Copy Destination:=Sht6.Range("A3:Q" & LastRow6 + 2) Next End Sub T1 --Data.xlsb

تم تعديل الكود الى frmMyUserForm.Show vbModeless DoEvents --- --- --- --- Unload frmMyUserForm واصبح كل شي تمام الحمد لله

السلام عليكم ورحمة الله وبركاته اردت ان اظهر فورم اثناء عمل كود بحيث تظهر الفورم منذ بداية تنفيذ الكود وتختفي عند انتهاء الكود فاستخدمت هذا الكود frmMyUserForm.Show vbModeless --- --- --- --- Unload frmMyUserForm ولكن تظهر لي الفورم فارغة والكود بعمل ما فيه مشكلة فما الحل

شكرا جزيلا

تم التوصل للحل عن طريق اضافة .Net Framework 3.5 اذا امكن كود لا يعتمد على هذه

توضيح المفروض يتم ايجاد اعللى خمس قيم في عمود المتوسط في Data ومن ثم استخلاص اسماء المدارس المقابلة لها ثم كتابتها في النطاقة من c8 الى c13 في صفحة firstfive وهذا بناء على اختيار الشعبة والمادة في الخلية V7 والخلية V8 في ورقة firstfive

السلام عليكم ورحمة الله وبركاته منذ فترة طلبت من حضراتكم كون بحيث يقوم رترتيب البيانات ومن ثم ايجاد اسماء المدارس الخمسة الاوئل ووضعها في خلايا معينة وقدم لي الاستاذ سليم حاصبيا كود لذلك وكان يعمل جيدا لكن الحين تم ترقية الاجهزة لدينا في المدرسة الى Office 365 App for interprise واصبح الكود يعطي خطا في السطر Set Col = CreateObject("System.Collections.ArrayList") Sub FirstFive_New() 'On Error Resume Next Dim sh As Worksheet Dim sh1 As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long, a% Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim Col As Object, Dic As Object Dim Lt, t%, Ar_count, y, kk% Dim Mn, A_arr() Application.ScreenUpdating = False If Range("AB3").Value = "ABCDEF" Then Columns("D").EntireColumn.Hidden = True Columns("F").EntireColumn.Hidden = True Columns("H").EntireColumn.Hidden = True Columns("J").EntireColumn.Hidden = False Columns("K").EntireColumn.Hidden = False Columns("I").EntireColumn.Hidden = False ElseIf Range("AB3").Value = "ABCDF" Then Columns("D").EntireColumn.Hidden = True Columns("F").EntireColumn.Hidden = True Columns("H").EntireColumn.Hidden = True Columns("J").EntireColumn.Hidden = False Columns("K").EntireColumn.Hidden = True Columns("I").EntireColumn.Hidden = False ElseIf Range("AB3").Value = "ABBBCCF" Then Columns("F").EntireColumn.Hidden = False Columns("H").EntireColumn.Hidden = False Columns("D").EntireColumn.Hidden = True Columns("J").EntireColumn.Hidden = True Columns("K").EntireColumn.Hidden = True Columns("I").EntireColumn.Hidden = True Else Columns("D").EntireColumn.Hidden = False Columns("F").EntireColumn.Hidden = False Columns("H").EntireColumn.Hidden = False Columns("J").EntireColumn.Hidden = False Columns("K").EntireColumn.Hidden = False Columns("I").EntireColumn.Hidden = False End If Set sh = Sheets("DataT1") Set sh1 = Sheets("FirstFiveT1") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh1.Range("C8:C13").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone ' If sh1.Range("V8") = "" Then GoTo 1 'sh1.Range("V8") = "Grade 1" ' If sh1.Range("V7") = "" Then sh1.Range("V7") = "Arabic Language" Cret1 = sh1.Range("V8"): Cret2 = sh1.Range("V7") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) Ar_count = My_rg.Areas.Count For y = 2 To Ar_count For kk = 1 To My_rg.Areas(y).Rows.Count ReDim Preserve A_arr(a) A_arr(a) = _ My_rg.Areas(y).Cells(kk) a = a + 1 Next kk Next y If a = 0 Then Exit Sub For i = LBound(A_arr) To UBound(A_arr) If IsNumeric(A_arr(i)) Then Col.Add Val(A_arr(i)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next m = 8: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) If Not F_rg Is Nothing Then xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh1.Cells(m, "C") .Value = sh.Cells(Lt, "B") ' .Offset(, 1).Resize(, 9).Value = _ ' sh.Cells(Lt, "D").Resize(, 9).Value ' .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop End If t = t + 1 If t = Dic.Count Then Exit Do Loop If sh.FilterMode Then My_rg.AutoFilter End If Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase A_arr If Range("Q12").Value = 0 Then Rows("12").EntireRow.Hidden = True Else Rows("12").EntireRow.Hidden = False End If Range("C8").Select End Sub هل يمكن حل هذه المشكلة FirstFives.xlsb

=IF(A1<=1250,A1*0.025,IF(A1<=2500,31.25+(A1-1250)*0.1,IF(A1<=3750,156.25+(A1-2500)*0.1)))

لم استطع فهم تسلسل الكود

الكود التالي لتحديد عدد الصفوف في كل صفحة For i = 33 To 3300 Step 33 ActiveSheet.HPageBreaks.Add Before:=Cells(i + 1, 1) Next

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= ThisWorkbook.Path & "\" & "FileNAme", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False جرب هذا الكود FileNAme اسم الملف المراد التسمية به

اذا تم حذفها يعطي اسم واحد مكرر بعدد طلاب الفصل شكرا لاهتمام حضرتك

شكرا جزيلا استاذ محي الدين اذا تم حذف الترقيم الموجود في العمود A في صفحة اسماء الطلاب وتشغيل الكود لا يعطي اي اسماء وكذلك اذا تم ترقيم الاسماء كلها بتسلسل واحد مثلا من 1 الى 100 اذا تم حذف الترقيم الموجود في العمود A في صفحة اسماء الطلاب وتشغيل الكود لا يعطي اي اسماء وكذلك اذا تم ترقيم الاسماء كلها بتسلسل واحد مثلا من 1 الى 100 فما علاقة الكود بهذا العمود

معذرة المطلوب هو عند كتابة قيمة الخلية AB1 تساوي أي من الاشكال التالية 12A 12-1 12/1 يقوم بالبحث عنها في اسماء الطلاب بحيث اذل وجده في اسماء الطلاب 12A يعطيني البيانات أو اذا وجده اي حالة من الحالتين الاخرين تعطي النتيجة ايضا ولا اريد ان يعتمد على البيانات الموجود في العمود A في اسماء الطلاب

توصلت إلى حل عن طريق اضافة عمود في صفحة الاسماء كما هو موضح بالمرفق واستخدمت المعادلة التالية =IFERROR(IF(LangCod=2,VLOOKUP($AB$1&"|"&A8,StudentsNames,5,0),VLOOKUP($AB$1&"|"&A8,StudentsNames,4,0)),"") ولكن ما زلت اطمع في حل عن طريق تعديل الكود 1111.xlsb