ناصر سعيد قام بنشر مايو 7, 2017 الكاتب مشاركة قام بنشر مايو 7, 2017 الكود بعد اضافه سطر مسح البيانات المرحله ومسح التسطير 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 *********** لماذا تاتي البيانات المرحله دائما محاذاتها ناحيه اليمين ؟ نريد محاذاتها في الوسط رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 7, 2017 مشاركة قام بنشر مايو 7, 2017 بسبب هذا السطر Range("A4:Z1000").Clear إذا أردت مسح البيانات فقط دون التنسيق استخدم ClearContents بدلاً من Clear 1 رابط هذا التعليق شارك More sharing options...
ناصر سعيد قام بنشر مايو 7, 2017 الكاتب مشاركة قام بنشر مايو 7, 2017 جزاك الله خيرا استاذ ياسر هذا كودكم الخاص باستدعاء يبانات بشرط اضفت عليه سطر لمسح المحتوى وسطر لمسح التسطير وسطر لوضع التسطير ولكن لم يتم ضبط التسطير 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 لم يتم ضبط التسطير .. لماذا ؟ رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 7, 2017 مشاركة قام بنشر مايو 7, 2017 ربما لأنك لم تشر لورقة العمل قبل النطاق Range المطلوب مسح بياناته رابط هذا التعليق شارك More sharing options...
ناصر سعيد قام بنشر مايو 7, 2017 الكاتب مشاركة قام بنشر مايو 7, 2017 Sheets("Sheet2").Range("A4:Z1000").ClearContents لم يحدث تغيير .. التسطير لايتم على المدى في صفحه الهدف المطلوب الترحيل اليها رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 7, 2017 مشاركة قام بنشر مايو 7, 2017 شوف النطاق الذي يحتوي النتائج بالضبط وقم بتسطيره .. لا أدري ما المشكلة التي تواجهها بالضبط رابط هذا التعليق شارك More sharing options...
ناصر سعيد قام بنشر مايو 7, 2017 الكاتب مشاركة قام بنشر مايو 7, 2017 هذا هو الملف الذي يوجد به كودكم المطلوب تسطير خلايا النطاق المرحل اليه البيانات .. وشكرا استدعاء بشرط.rar رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 7, 2017 مشاركة قام بنشر مايو 7, 2017 جرب آخر سطرين بهذا الشكل Sheets("Sheet2").Range("E5:G" & Rows.Count).Borders.Value = 0 Sheets("Sheet2").Range("E6").CurrentRegion.Borders.Value = 1 1 رابط هذا التعليق شارك More sharing options...
ناصر سعيد قام بنشر مايو 7, 2017 الكاتب مشاركة قام بنشر مايو 7, 2017 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 كود الاستدعاء بشرط مع التحسينات في التسطير رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر مايو 8, 2017 مشاركة قام بنشر مايو 8, 2017 (معدل) السلام عليكم ورحمة الله اولا اود ان اشكر استاذنا ياسر خليل ابو البراء وكذلك الاستاذ ناصر سعيد بعذ ادن الاخ ياسر خليل ابو البراء قمت بتعديل بسيط للكود يعني الكود يفلتر البيانات حسب الخلية K5 في الشيت2 ولكن عند ادخال رقم غير موجود في الخلية K5 تحدث مشاكل . استاذ ياسر خليل .... فضلا ما حل هذه المشكة ؟ ' قمت بالغاء هذا السطر في الكود If arr(i, 3) Like "*" & "äÇ*" & "*" Then واضفت هذا السطر If arr(i, 1) = Range("k5") Then بحث بشرط.rar تم تعديل مايو 8, 2017 بواسطه حسين مامون رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 8, 2017 مشاركة قام بنشر مايو 8, 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("E6:H1000").Clear lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row arr = Sheets("Sheet1").Range("A2:D" & 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, 4) = Range("K5") 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 If j = 1 Then MsgBox "Invalid Criteria", vbExclamation: Exit Sub Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("الكود", "الأسماء", "الدرجات", "الحالة") Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر مايو 8, 2017 مشاركة قام بنشر مايو 8, 2017 21 دقائق مضت, ياسر خليل أبو البراء said: وعليكم السلام ورحمة الله وبركاته جرب التعديل التالي 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("E6:H1000").Clear lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row arr = Sheets("Sheet1").Range("A2:D" & 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, 4) = Range("K5") 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 If j = 1 Then MsgBox "Invalid Criteria", vbExclamation: Exit Sub Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("الكود", "الأسماء", "الدرجات", "الحالة") Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub اخي اشكرك على الاهتمام جربت الكود لم يعد يعمل يبحث حتى على الارقام الموجودة في العمود a في كل بحث يعطي رسالة "Invalid Criteria" رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر مايو 8, 2017 مشاركة قام بنشر مايو 8, 2017 اخي اشكرك حلت المشكلة غيرة رقم العمود من 4 الى 1 If arr(i, 4) = Range("K5") Then If arr(i, 1) = Range("K5") Then جزاك الله خيرا رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر مايو 8, 2017 مشاركة قام بنشر مايو 8, 2017 اعتقدت أنك تبحث في عمود الحالة وليس العمود الأول .. عموماً لو شاهدت الفيديو الخاص بالكود يمكنك فهم كيفية عمل الكود بشكل أفضل الحمد لله أن تم حل المشكلة تقبل تحياتي 1 رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر مايو 8, 2017 مشاركة قام بنشر مايو 8, 2017 نعم اخي شاهدت الفيديو ومن خلاله توصلت الى حل على كل حال الفضل يعود الى الله اولا والي حضرتك الحمد لله الف الف شكر لك استاذي 1 رابط هذا التعليق شارك More sharing options...
ناصر سعيد قام بنشر مايو 8, 2017 الكاتب مشاركة قام بنشر مايو 8, 2017 الاستاذ حسين السلام عليكم ورحمة الله فضلا ضع المرفق الخاص بك ليكون مرجعا لغيرنا وتنال ان شاء الله العفو والمغفره 1 رابط هذا التعليق شارك More sharing options...
حسين مامون قام بنشر مايو 9, 2017 مشاركة قام بنشر مايو 9, 2017 السلام عليكم ورحمة الله استاذ ناصر سعيد الف شكر لك اخي بخصوص الموضوع ليس لدي اي مرفق فقط اعجبني كود الاخ ياسر خليل واردت الاستفاذة كغيري من محبي الاكسيل تحياتي 1 رابط هذا التعليق شارك More sharing options...
الهمة قام بنشر مايو 10, 2017 مشاركة قام بنشر مايو 10, 2017 تسلم أستاذ ياسر خليل دائما تتحفنا بالجديد. 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها