[ahmed12345a]

هذا الكود خاص بالترحيل او الاستدعاء .
.. رائع بهذا الكود يكون اكتملت اكواد اي كنترول
يمكن عمله....
وحجمه ان شاء الله لايتخطى 4 ميجا ( ابدأ من حيث انتهى الاخرون )

'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'تم هذا الكود في 15/2/2017
sub استدعاء()
dim arr as variant
dim temp as variant
dim cr as variant
dim lr as long
dim i as long
dim j as long
dim c as long
dim ws as worksheet
dim sh as worksheet
set ws = sheets("sheet1")
set sh = sheets("sheet2")
'= = = = = = = = = = = =
' شيت الهدف والمدى المطلوب مسحه
sh.range("b7:aj10000").clearcontents

' اسم ورقة المصدر
lr = ws.cells(rows.count, 1).end(xlup).row

'متغير اسم ورقة المصدرومدى البيانات بها
arr = ws.range("a7:ef" & lr).value

redim temp(1 to ubound(arr, 1), 1 to ubound(arr, 2))

'ارقام الاعمده المطلوب نقلها
cr = array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73)
j = 1

for i = lbound(arr, 1) to ubound(arr, 1)

' المعيار او الشرط الذي نبحث به ورقم عمود المعيار
if arr(i, 135) like "*" & "نا*" & "*" then
temp(j, 1) = j
for c = lbound(cr) to ubound(cr)
temp(j, c + 2) = arr(i, cr(c))
next c
j = j + 1
end if
next i

' اسم شيت الهدف
with sh
'====

'خليه بدايه اللصق في شيت الهدف
.range("b7").resize(j - 1, ubound(temp, 2)).value = temp

'سطر لمسح التسطير
.range("b7:aj" & rows.count).borders.value = 0

'سطر لاضافة التسطير
.range("b7:aj" & .cells(rows.count, 2).end(xlup).row).borders.value = 1
end with
end sub