ناصر سعيد

تفضل اخي الكريم استاذ محمد صالح

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

جزاك الله خيرا .. نفس صوره الخطأ السابقه

يارب .. اعد الينا كل الاحبه الغائبين

نسخه الويندوز اكس بي اوفيس 2010 صوره الخطأ تم تصويرها الملف مرفق القيم الفريــده.rar

هل هذا السطر arr = Sheets("Sheet1").Range("A3").CurrentRegion.Value يغني عن 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A2:C" & lr).Value جزاك الله خيرا

الترحيل بشرط معين في عمود معين بسهوله ويسر بالمصفوفات للنابغه ياسر خليل Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل بشرط 'تم هذا الكود في 15/2/2017 Sub UsingArrays() Dim arr As Variant Dim temp As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A2:C" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به If arr(i, 3) Like "*" & "P" & "*" Then For c = LBound(arr, 2) To UBound(arr, 2) temp(j, c) = arr(i, c) Next c j = j + 1 End If Next i 'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("Names", "Marks", "Status") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub استدعاء بشرط.

رائعة النابغه ياسر خليل في الترحيل بالمصفوفات ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات (كود حصري) https://youtu.be/ndC28IqkkBw ** من يريد دعمي فليقم بالاشتراك في القناة وعمل لايك للفيديوهات https://www.file-upload.com/ablfo2nqpekx رابط الملف السابق ============================================== الترحيل بشرط معين في عمود معين بسهوله ويسر بالمصفوفات للنابغه ياسر خليل Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل بشرط 'تم هذا الكود في 15/2/2017 Sub UsingArrays() Dim arr As Variant Dim temp As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A2:C" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به If arr(i, 3) Like "*" & "P" & "*" Then For c = LBound(arr, 2) To UBound(arr, 2) temp(j, c) = arr(i, c) Next c j = j + 1 End If Next i 'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("Names", "Marks", "Status") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub ستدعاء بشرط.rar ملف الكود السابق

============= استدعاء بشرط.rar ملف الكود السابق

الترحيل بشرط معين في عمود معين بسهوله ويسر بالمصفوفات للنابغه ياسر خليل Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل بشرط 'تم هذا الكود في 15/2/2017 Sub UsingArrays() Dim arr As Variant Dim temp As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A2:C" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به If arr(i, 3) Like "*" & "P" & "*" Then For c = LBound(arr, 2) To UBound(arr, 2) temp(j, c) = arr(i, c) Next c j = j + 1 End If Next i 'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("Names", "Marks", "Status") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub

لو تكرمت يا استاذ ياسر نريد ان يتم الترحيل بشرط معين في عمود معين ... مثال كلمه ناجح .. ناج*

Option Explicit Sub Test() 'متغيرات Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long 'اسم شيت المصدر واسم الخليه الاولى منه arr = Sheets("Sheet1").Range("A3").CurrentRegion.Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 9) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(2, 6, 10) 'اسم شيت الهدف ورقم صف صفحة الهدف Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) j = j + 1 Next i End Sub سحر الاكواد

رائعة النابغه ياسر خليل في الترحيل بالمصفوفات ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات (كود حصري) https://youtu.be/ndC28IqkkBw ** من يريد دعمي فليقم بالاشتراك في القناة وعمل لايك للفيديوهات ============= رابط الملف https://www.file-upload.com/ablfo2nqpekx

اشكرك الاستاذ المحترم محمد طاهر على ردك واود ان اوضح التالي جزاكم الله خيرا توسيط المشاركات سيقبله الجميع وان وجد احد الاشخاص يريد ان يجعل مشاركته جهة اليمين مثلا فالخيارات موجوده امامه .. ستعطي للمنتدى جمالا فوق جماله وممكن ان تعمل فتره تجربه توسط فيها المشاركات بخط مقاس 22 وشوف رد الفعل ثانيا كلامك منطقي جدا في موضوع ترك مده 3 دقائق يتم فيها التغيير دون كتابه تم التعديل ولكن يمكن ان نجعل المده مثلا عدد 2 دقيقه او دقيقه سماح للمشارك مثل كثير من المنتديات ماجتش من دقيقتين .. او دقيقه وعلى الله قصد السبيل

الاستاذ المبجل سليم حاصبيا السلام عليكم ورحمة الله وبركاته ربنا يزيك علما وحلما يارب العالمين .. وبعد الكود يعطي هذه الرساله

الجديد اختلاف مكان صف بدايه صفحه المصدر وصف البدايه لصفحة الهدف 'Private Sub Worksheet_Activate() Sub القــيم_الفريده() 'Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False 'مسح عمود القيم الفريده [S9:S500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [S9:S500] 'اسم شيت المصدرورقم صف البدايه في شيت الهدف For U = 9 To Sheets("بيانات الطلبة").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدروكذلك رقم الصف في شيت المصدر Cells(U, 19) = Sheets("بيانات الطلبة").Cells(U - 2, 22) 'رقم عمودالبيانات الفريده في الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 19)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 19).ClearContents End If Next 'فرز عمود القيم الفريده [S9:S500].Sort [S9], xlAscending Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=128040

شهادات بطريقه العلامه عبد الله بتنسيقات جديده '*********************************************** '*********************************************** ' اسم ورقة الشهادات Const ShName As String = "شهادات الصف الثانى" ' رقم اول صف للشهادة Const FirstRow As Integer = 7 ' عدد صفوف الشهادة Const CountRow As Integer = 16 'عدد اعمدة الشهادة التي تريد اظهارها في الطباعة Const CountColumn As Integer = 13 ' خلية موقع الطالب لمعادلات الشهادة Const Range_Index As String = "A7" '===================================== ' اسم ورقة البيانات Const Sh As String = "بيانات أساسية" ' نطاق ناجح دور ثاني في ورقة البيانات Const MyND As String = "Q6:Q5000" ' نطاق الاسماء في ورقة البيانات Const MyNSearch As String = "C6:C5000" '===================================== ' خلية عدد كل المتقدمين Const CountAll As String = "Q1" ' خلية عدد الناجحين Const CountNA As String = "Q2" ' كلمة البحث عن الناجحين Const NA_G As String = "نا*" ' خلية عدد دور ثاني Const CountDT As String = "Q3" ' كلمة البحث عن دور ثاني Const DT_G As String = "له* دور تان" 'Const CountDOR As String = "Q4" ' كلمة البحث عن دور ثاني 'Const DT_G As String = "له* دور تان" '************************* '========================== ' خلية عدد كل المتقدمين Dim kh_Test As Boolean Sub All_Students_2() Application.ScreenUpdating = False kh_ClearContents_2 With Sheets(ShName) .Range(Range_Index).Value = 1 Call kh_Test_Fill(.Range(CountAll)) End With If kh_Test Then Application.ScreenUpdating = True End If AddPageBreaks Range("b1").Select End Sub Sub Successful_Students_2() Application.ScreenUpdating = False kh_ClearContents_2 With Sheets(ShName) Call kh_Test_Fill(.Range(CountNA)) If kh_Test Then Call kh_Nd(NA_G) End With Application.ScreenUpdating = True AddPageBreaks Range("b1").Select End Sub Sub Second_Students_2() Application.ScreenUpdating = False kh_ClearContents_2 With Sheets(ShName) Call kh_Test_Fill(.Range(CountDT)) If kh_Test Then Call kh_Nd(DT_G) End With Application.ScreenUpdating = True AddPageBreaks Range("b1").Select End Sub Sub DOR_Students_2() Application.ScreenUpdating = False kh_ClearContents_2 With Sheets(ShName) Call kh_Test_Fill(.Range(CountDOR)) If kh_Test Then Call kh_Nd(DOR_G) End With Application.ScreenUpdating = True AddPageBreaks Range("b1").Select End Sub Sub Item_Search_2() Dim NN As Integer, R As Integer, c As Integer, rr As Long NN = form_Search_2.CM_ListAdd.ListCount Application.ScreenUpdating = False kh_ClearContents_2 With Sheets(ShName) If NN = 1 Then .Range(Range_Index).Value = form_Search_2.CM_ListAdd.List(0, 1) Else Call kh_AutoFill(NN) rr = .Range(Range_Index).Row c = .Range(Range_Index).Column For R = 0 To NN - 1 .Cells(rr, c) = form_Search_2.CM_ListAdd.List(R, 1) rr = rr + CountRow Next End If ActiveWorkbook.Application.DisplayFullScreen = False End With Unload form_Search_2 Application.ScreenUpdating = True End Sub Sub kh_Test_Fill(MyCel As Range) If IsNumeric(MyCel) And MyCel.Value > 0 Then kh_Test = True If MyCel.Value <> 1 Then Call kh_AutoFill(MyCel.Value) Else kh_Test = False MsgBox MyCel.Offset(0, -1) & Chr(10) & Chr(10) & Val(MyCel), 524288 + 1048576 + 16, "بيانات غير متوفرة" End If End Sub Sub kh_AutoFill(R As Integer) Dim SourceRange As Range, fillRange As Range Dim rr As Long rr = (R * CountRow) With Sheets(ShName) Set SourceRange = .Rows(FirstRow).Resize(CountRow) Set fillRange = .Rows(FirstRow).Resize(rr) SourceRange.AutoFill fillRange, xlLinearTrend .PageSetup.PrintArea = .Range("B" & FirstRow).Resize(rr, CountColumn).Address End With End Sub Sub kh_Nd(Nd As String) Dim MyRng As Range Dim R As Integer, c As Integer, rr As Long Set MyRng = Sheets(Sh).Range(MyND) With Sheets(ShName) rr = .Range(Range_Index).Row c = .Range(Range_Index).Column End With With MyRng For R = 1 To .Rows.Count ' If .Cells(R, 1) = Nd Then If .Cells(R, 1) Like "*" & Nd & "*" Then Sheets(ShName).Cells(rr, c) = R rr = rr + CountRow End If Next End With End Sub Sub kh_ClearContents_2() Dim T As Long With Sheets(ShName) .Range(Range_Index).ClearContents T = .UsedRange.Rows.Count .Rows(FirstRow + CountRow).Resize(T).Delete Application.GoTo .Range(Range_Index), True End With End Sub Sub kh_Delete_2() Application.ScreenUpdating = False kh_ClearContents_2 Application.ScreenUpdating = True ThisWorkbook.save MsgBox "تم مسح الشهادات وحفظ العمل", vbMsgBoxRight, "الحمد لله" Range("b1").Select End Sub Sub Kh_Search_2() Load form_Search_2 With form_Search_2 .Tag = Sh .CM_TextFind.Tag = MyNSearch .Show End With End Sub '========================================================= '========================================================= Sub AddPageBreaks() Dim R As Long, LR As Long LR = ورقة12.[A5000].End(xlUp).Row ActiveSheet.ResetAllPageBreaks For R = (5 + 49) To LR Step 48 ActiveSheet.HPageBreaks.Add Before:=Cells(R, 1) Next 'Set ActiveSheet.HPageBreaks(1).Location = Range("B6") End Sub شهادات بطريقه العلامه باقشير.rar

'Private Sub Worksheet_Activate() Sub القــيم_الفريده() 'Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False 'مسح عمود القيم الفريده [S9:S500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [S9:S500] 'اسم شيت المصدرورقم صف البدايه في شيت الهدف For U = 9 To Sheets("بيانات الطلبة").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدروكذلك رقم الصف في شيت المصدر Cells(U, 19) = Sheets("بيانات الطلبة").Cells(U - 2, 22) 'رقم عمودالبيانات الفريده في الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 19)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 19).ClearContents End If Next 'فرز عمود القيم الفريده [S9:S500].Sort [S9], xlAscending Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub ربنا يبارك لك استاذ ياسر خليل

الله اكبر ... الله اكبر .. ربنا يحفظك ويصونك يا استاذ ياسر ===== شرح ولا اسهل القيم الفريــده.rar وهذا تطبيق الشرح

كتبها الله لك في كفة حسناتك ... يارب شكرا لك استاذ زيزو

جزاكم الله خيرا وبارك فيكم ارجو توضيح كبف اجعل صف صفحة بيانات المصدر مختلفه عن صف بيانات الهدف يعني في الكود الموجود الصف التاسع ..... ليضع البيانات الفريده في الصف التاسع وياخذ البيانات من صفحة المصدر من الصف التاسع واحنا عايزين نجعل ياخد بيانات المصدر من الصف السابع

للرفع رفع الله مقداركم

جزاك الله كل خير الاستاذ المحترم محمد طاهر هل يمكن جعل المشاركات افتراضيا في وسط الصفحه ويمقاس 22 افتراضيا ==== وان تجعل من فضلك بعد المشاركه مده مثلا 3 دقائق يستطيع المشارك من نغيير مشاركته بدون ظهور تم التغيير لانها تشوه منظر الصفحه ولك خالص تقديري واحترامي لشخصكم الكريم وعلى الله قصد السبيل

نرجو شرح اسطرالكود .. من فضلك

يجزيك الله كل خير وبارك في صحتك واهلك ومالك اخي الكريم استاذ زيزو .. يارب