بحث مخصص من جوجل فى أوفيسنا
Custom Search
|
البحث في الموقع
Showing results for tags 'استدعاء اعمده معينه وبشرط النجاح'.
تم العثور علي 1 نتيجه
-
كل عام وانتم بخير .. وبعد نريد من افذاذ المنتدى ان ياتي هذا الكود باعمده معينه وليس الصفحه كامله مع وجود شرط النجاح الموجود بالفعل .. كرما منكم 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
