اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

بسم الله الرحمن الرحيم

احبابنا في الله

جزاكم الله خيرا .. وبعد :

هذا كود للمحترم ياسر خليل يجزيه الله بكل خير

لاستدعاء بيانات من اعمده مختلفه .... لاعمده متجاوره بدء من خليه معرفه بالداله

 
'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'وكذلك الاستدعاء بدون شرط
'وقد تم التنويه داخل الكود عن السطر المسئول
'تم هذا الكود في 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
    Set Main = Sheets("رصد الترم الأول")
    Set sh = Sheets("كشوف الترم الأول")
    '= = = = = = = = = = = =
    ' شيت الهدف والمدى المطلوب مسحه
    sh.Range("B8: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, 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

 

 

 

 

 

 

قام بنشر
===============
هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'وكذلك الاستدعاء بدون شرط بسطر برمجي جديد
'وقد تم التنويه داخل الكود عن السطر المسئول
 
 
'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'وكذلك الاستدعاء بدون شرط بسطر برمجي جديد
'وقد تم التنويه داخل الكود عن السطر المسئول
'تم هذا الكود في 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 = "ذكر*"    'خلية البحث

    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 & "*" 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

 

قام بنشر
 
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرطين
'وكذلك الاستدعاء بدون شرط
'وقد تم التنويه داخل الكود عن السطر المسئول

 


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

 

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information