'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرطين
'وكذلك الاستدعاء بدون شرط
'وقد تم التنويه داخل الكود عن السطر المسئول
'تم هذا الكود في 15/2/2017
'==================
Sub Tarheeel()
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
Dim myArray, targt, targt1
targt = "ذك*"
targt2 = "أنث*"
Set Main = Sheets("رصد الترم الأول")
Set sh = Sheets("كشوف الترم الأول")
'= = = = = = = = = = = =
' شيت الهدف والمدى المطلوب مسحه
sh.Range("B7:AE1000").ClearContents
' عدد الصفوف في ورقة المصدر
lr = Main.Cells(Rows.count, 1).End(xlUp).Row
'متغير اسم ورقة المصدرومدى البيانات بها
arr = Main.Range("A7:EF" & lr).Value
ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
'ارقام الاعمده المطلوب نقلها
cr = Array(2, 3, 6, 78, 9, 79, 12, 80, _
15, 81, 20, 82, 21, 83, 22, 84, 24, 85, _
25, 86, 87, 87)
j = 1
For i = LBound(arr, 1) To UBound(arr, 1)
'==================
'اذا أردت ان يستدعي بيانات بدون شرط
'ماعليك الا ان تجعل السطر البرمجي الموجود
'اسفل هذا السطر لا يعمل
'==================
'رقم عمود الذي سيتم البحث فيه
If arr(i, 74) Like targt & "*" _
Or arr(i, 74) Like targt2 & "*" 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
[1]
مطلوب اضافه لكود ترحيل بالمصفوفات
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق