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

[ناصر سعيد]

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

اخواني في الله

هذا ملف جامع

لموضوع استدعاء البيانات من اعمده مختلفه 

بمعايير مختلفه

من المحترم الاستاذ النشط ياسر خليل

حفظه الله

 

استدعاء بمعيارين من الخارج3.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
    Dim myArray, targt, targt2
    
    Set Main = Sheets("المصدر")
    Set sh = Sheets("Sheet2")
    
    targt = sh.Range("C1").Value & "*"
    targt2 = sh.Range("C2").Value & "*"
    'targt = "ذك*"
    'targt2 = "نا*"


    '= = = = = = = = = = = =
    ' شيت الهدف والمدى المطلوب مسحه
    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, 7, 8, 9, 11, 5, 135)
    
    j = 1
 
    For i = LBound(arr, 1) To UBound(arr, 1)
    '==================
    'اذا أردت  ان يستدعي بيانات بدون شرط
    'ماعليك الا ان تجعل السطر البرمجي الموجود
    'اسفل هذا السطر لا يعمل
    '==================
               'رقم عمود الذي سيتم البحث فيه
       If arr(i, 5) Like targt & "*" _
       And arr(i, 135) 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

 

[ناصر سعيد]

*********************************

 
'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'وكذلك الاستدعاء بدون شرط بسطر برمجي جديد
'وقد تم التنويه داخل الكود عن السطر المسئول
'تم هذا الكود في 15/2/2017
    '==================
    Sub استدعاء_بمعيار1()
    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
    Set Main = Sheets("المصدر")
    Set sh = Sheets("Sheet2")

    targt = "ذكر*"    'خلية البحث

    '= = = = = = = = = = = =
    ' شيت الهدف والمدى المطلوب مسحه
    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, 7, 8, 9, 11, 5, 135)
    
    j = 1
 
    For i = LBound(arr, 1) To UBound(arr, 1)
    '==================
    'اذا أردت  ان يستدعي بيانات بشرط
    'ماعليك الا ان تجعل السطر البرمجي الموجود
    'اسفل هذا السطر يعمل
    '==================
               'رقم عمود الذي سيتم البحث فيه
        If arr(i, 5) 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 استدعاء_بدون_شرط()
    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("المصدر")
    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, 5, 135)
      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

 

[ناصر سعيد]

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

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

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

وهو خاص للمحترم الذي اكن له كل تقدير واحترام

الاستاذ زيزو العجوز

'================
Sub Trans_Data()

'الكود خاص بالمحترم زيزو العجوز
'يحفظه الله
'تم هذا الكود في 15/11/2017
'الهدف من الكود هو استدعاء صفحة كامله بشرط
'================
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'الاعلان عن اسماء الشيتات'
Dim Main As Worksheet, sh As Worksheet

'  الاعلان عن المصفوفتين
Dim Arr As Variant, Temp As Variant

'(i,j)الاعلان عن ابعاد المصفوفة الاولى ( p  ) وعداد المصفوفة الثانية
Dim i As Long, j As Long, p As Long

' الاعلان عن المتغير الذى سوف يتم العمل عليه
Dim dep As String

Set Main = Sheets("المصدر")
Set sh = Sheets("الهدف")
'=======
'  محو البانات القديمة
sh.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).ClearContents

'    معيار الاختيار
dep = sh.Range("C1").Value

 '     المصفوفة المصدر
Arr = Main.Range("A7:CX" & Main.Range("B" & Rows.Count).End(xlUp).Row).Value

'     ابعاد المصفوفة الهدف
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))

 '     طول المصفوفة المصدر
For i = 1 To UBound(Arr, 1)

 'رقم عمود الشرط
If Arr(i, 101) Like "*" & dep & "*" Then

'If Arr(i, 101) = dep Then
 '    العداد لتحديد طول المصفوفة الهدف
p = p + 1

 '     عرض المصفوفة الهدف
For j = 1 To UBound(Arr, 2)

'  تعبئة المصفوفة الهدف من المصفوفة المصدر حسب الشرط
Temp(p, j) = Arr(i, j)

Next
End If
Next

 '  خليه البدايه لصفحه الهدف
 'عرض البيانات المطلوبة
If p > 0 Then sh.Range("A7").Resize(p, UBound(Temp, 2)).Value = Temp

       sh.Range("A7:CX" & Rows.Count).Borders.Value = 0
        
        'سطر لاضافة التسطير
       sh.Range("A7:CX" & Cells(Rows.Count, 2).End(xlUp).Row).Borders _
       .Weight = xlMedium
        
     ' .Weight = xlThin
     ' .Weight = xlMedium
     ' .Weight = xlThick

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

 

==========

 

استدعاء صفحة بشرط.rar