استدعاء اعمده معينه وبشرط النجاح

[ناصر سعيد]

كل عام وانتم بخير .. وبعد

نريد من افذاذ المنتدى

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

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

[ناصر سعيد]

للرفع رفع الله مقداركم

[ناصر سعيد]

للرفع رفع الله مقداركم

[ناصر سعيد]

للرفع رفع الله مقداركم

[abdalim2]

باستخدام ِAdvanced Filter

 

 

استدعاء بشرط.zip

[ناصر سعيد]

شكرا لك اخي الكريم

ولكن تعطي هذه الرساله

 

[ناصر سعيد]

ربنا يبارك فيك استاذ ياسر .. عمل ولا اروع

'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'تم هذا الكود في 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
    'متغير اسم شيت الهدف والمدى المطلوب مسحه
    Sheets("Sheet2").Range("B7:AJ10000").ClearContents
    
        'متغير اسم ورقة المصدر
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
            'متغير اسم ورقة المصدرومدى البيانات بها
    arr = Sheets("Sheet1").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 Sheets("Sheet2")
        .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

 

========================

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

استدعاء بشرط.rar

[ياسر خليل أبو البراء]

بارك الله فيك أخي العزيز ناصر وجزيت خيراً على كلماتك الطيبة

تقبل وافر تقديري واحترامي

[ناصر سعيد]

تمام التمام ... ربنا يحفظك ويصونك يارب
يا استاذ ياسر

 

'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'تم هذا الكود في 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

 

هذا ملف الكود وبه اسم شيت المصدر واسم شيت الهدف من ضمن المتغيرات في اول الكود

استدعاء بشرط.rar