ناصر سعيد

كل عام وانتم بخير .. وبعد نريد من افذاذ المنتدى ان ياتي هذا الكود باعمده معينه وليس الصفحه كامله مع وجود شرط النجاح الموجود بالفعل .. كرما منكم 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 Sheets("Sheet2").Range("A4:Z1000").ClearContents 'متغير اسم ورقة المصدر 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 "*" & "نا*" & "*" 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("الاسماء", "الدرجات", "الحالة") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير Sheets("Sheet2").Range("E5:G" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير Sheets("Sheet2").Range("E6").CurrentRegion.Borders.Value = 1 End Sub استدعاء بشرط.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 Sheets("Sheet2").Range("A4:Z1000").ClearContents 'متغير اسم ورقة المصدر 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 "*" & "نا*" & "*" 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("الاسماء", "الدرجات", "الحالة") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير Sheets("Sheet2").Range("E5:G" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير Sheets("Sheet2").Range("E6").CurrentRegion.Borders.Value = 1 End Sub كود الاستدعاء بشرط .. مع التحسينات في التسطير استدعاء بشرط.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 Sheets("Sheet2").Range("A4:Z1000").ClearContents 'متغير اسم ورقة المصدر 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 "*" & "نا*" & "*" 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("الاسماء", "الدرجات", "الحالة") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير Sheets("Sheet2").Range("E5:G" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير Sheets("Sheet2").Range("E6").CurrentRegion.Borders.Value = 1 End Sub كود الاستدعاء بشرط مع التحسينات في التسطير

هذا هو الملف الذي يوجد به كودكم المطلوب تسطير خلايا النطاق المرحل اليه البيانات .. وشكرا استدعاء بشرط.rar

Sheets("Sheet2").Range("A4:Z1000").ClearContents لم يحدث تغيير .. التسطير لايتم على المدى في صفحه الهدف المطلوب الترحيل اليها

جزاك الله خيرا استاذ ياسر هذا كودكم الخاص باستدعاء يبانات بشرط اضفت عليه سطر لمسح المحتوى وسطر لمسح التسطير وسطر لوضع التسطير ولكن لم يتم ضبط التسطير 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 Range("A4:Z1000").ClearContents 'متغير اسم ورقة المصدر 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 "*" & "نا*" & "*" 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("الاسماء", "الدرجات", "الحالة") 'سطر لمسح التسطير Sheets("Sheet2").Range("E6").Resize(UBound(temp, 1)).Borders.Value = 0 'سطر للتسطير Sheets("Sheet2").Range("E6").Resize(UBound(temp, 1)).Borders.Value = 1 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub لم يتم ضبط التسطير .. لماذا ؟

Option Explicit Sub Test() 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير 'تم هذا الكود في 6/5/2017 'متغيرات Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'سطر لمسح النطاق Range("A4:Z1000").ClearContents lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'اسم شيت المصدر والمدى منه arr = Sheets("Sheet1").Range("A7:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 7) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(1, 3, 5) 'اسم شيت الهدف ورقم صف صفحة الهدف Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) 'سطر لمسح التسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0 'سطر للتسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1 j = j + 1 Next i End Sub كود استدعاء بيانات اعمده متفرقه لاعمده اخرى متفرقه في اخر تحسيناته

الكود بعد اضافه سطر مسح البيانات المرحله ومسح التسطير Option Explicit Sub Test() 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير 'تم هذا الكود في 6/5/2017 'متغيرات Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'سطر لمسح النطاق Range("A4:Z1000").Clear lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'اسم شيت المصدر واسم الخليه الاولى منه arr = Sheets("Sheet1").Range("A7:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 7) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(1, 3, 5) 'اسم شيت الهدف ورقم صف صفحة الهدف Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) 'سطر لمسح التسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0 'سطر للتسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1 j = j + 1 Next i End Sub

الكود بعد اضافه سطر مسح البيانات المرحله ومسح التسطير Option Explicit Sub Test() 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير 'تم هذا الكود في 6/5/2017 'متغيرات Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'سطر لمسح النطاق Range("A4:Z1000").Clear lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'اسم شيت المصدر واسم الخليه الاولى منه arr = Sheets("Sheet1").Range("A7:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 7) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(1, 3, 5) 'اسم شيت الهدف ورقم صف صفحة الهدف Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) 'سطر لمسح التسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0 'سطر للتسطير Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1 j = j + 1 Next i End Sub *********** لماذا تاتي البيانات المرحله دائما محاذاتها ناحيه اليمين ؟ نريد محاذاتها في الوسط

سهلها اكثر الله يسهلها عليك

الكود بعد اضافة ميزة تسطير الاعمده المرحل اليها Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير 'تم هذا الكود في 6/5/2017 Sub Test() 'متغيرات Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'اسم شيت المصدر واسم الخليه الاولى منه arr = Sheets("Sheet1").Range("A7:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 7) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(1, 3, 5) 'اسم شيت الهدف ورقم صف صفحة الهدف Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1 j = j + 1 Next i End Sub

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

تم الغاء هذا السطر ووضع السطر الذي تفضلتم به والاحظ السطر الملغى كان فيه الاندكس وتم الغاؤه وعمل الكود وتم تسطير الاعمده فقط ثانيا نريد تسطير النطاق بالكامل ' Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) ================== عمل الكود مره واحده تمام ولم يات بتائج المرات الاخرى

تفضل المرفق هذا الملف به الكود .. بالحــــدود.rar

جزاك الله خيرا اتت بخط اصفر في مكان اخر

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

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

رايط شرح كود استدعاء بيانات اعمده متفرقه لاعمده معينه اخرى =============== شرح الكود السابق

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

Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه 'تم هذا الكود في 15/2/2017 Sub Test() Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A1:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 9) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(2, 6, 10) Sheets("Sheet2").Cells(1, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) j = j + 1 Next i End Sub درر .. يجب الاحتفاظ بها مشاركات قام بنشر الان · ارسل تقرير عن المشاركه درر ...ترحيل اعمده معينه لاعمده اخرى في شيت اخر معينه Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه 'تم هذا الكود في 15/2/2017 Sub Test() Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A1:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 9) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(2, 6, 10) Sheets("Sheet2").Cells(1, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) j = j + 1 Next i End Sub استدعاء اعمد معينه لاعمده اخرى معينه.

ترحيل اعمده معينه لاعمده اخرى في شيت اخر معينه Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه 'تم هذا الكود في 15/2/2017 Sub Test() Dim arr As Variant Dim i As Variant Dim cr As Variant Dim j As Long Dim lr As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A1:K" & lr).Value 'الأعمدة المطلوب الترحيل إليها cr = Array(3, 5, 9) 'أرقام الأعمدة المطلوب ترحيلها For Each i In Array(2, 6, 10) Sheets("Sheet2").Cells(1, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i) j = j + 1 Next i End Sub استدعاء اعمد معينه لاعمده اخرى معينه.rar

وفقنا الله جميعا لكل ما يحب ويرضى وشكرا لحسن الرد