أكاديمية الصقر للتدريب


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





مطلوب اضافه لكود ترحيل بالمصفوفات

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



09-11-2017 12:02 صباحا
ناصر سعيد1
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
 offline 

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

هذا كود للاخ النشيط حفظه الله ياسر خليل
لترحيل اعمده غير متجاوره لاعمده غير متجاوره
المطلوب تغيير سطر او اضافه سطر ليكون الكود
لترحيل اعمده غير متجاوره

لاعمده متجاوره بمجرد كتابه رقم اسم الخليه في شيت الهدف
يرحل الاعمده اليها  ابتداء من الخليه اللي كتبناها ويرص الكود باقي الاعمده جنبها بدون احنا مانكتب ارقام الاعمده المرحل اليها
جزاكم الله خيرا
=====

Option Explicit
 
Sub Test()
 
'هذا الكود للمحترم النابغه ياسر خليل
 
'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير
 
'تم هذا الكود في 6/5/2017
 
'متغيرات
 
    Dim arr     As Variant
 
    Dim i       As Variant
 
    Dim cr      As Variant
 
    Dim j       As Long
 
    Dim lr      As Long
 
  'سطر لمسح النطاق
 
 Range("A4:Z1000").Clear
 
 lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
 
 
'اسم شيت المصدر واسم الخليه الاولى منه
 
 arr = Sheets("Sheet1").Range("A7:K" & lr).Value
 
    'الأعمدة المطلوب الترحيل إليها
 
    cr = Array(3, 5, 7)
 
 
    'أرقام الأعمدة المطلوب ترحيلها
 
    For Each i In Array(1, 3, 5)
 
    
 
    'اسم شيت الهدف ورقم صف صفحة الهدف
 
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
 
   'سطر لمسح التسطير
 
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0
 
   
 
   'سطر للتسطير
 
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1
        j = j + 1
    Next i
 
End Sub



09-11-2017 09:25 مساء
مشاهدة مشاركة منفردة [1]
ناصر سعيد1
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'وكذلك الاستدعاء بدون شرط
'وقد تم التنويه داخل الكود عن السطر المسئول

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



09-11-2017 10:31 مساء
مشاهدة مشاركة منفردة [2]
ناصر سعيد1
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
 
'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'وكذلك الاستدعاء بدون شرط بسطر برمجي جديد
'وقد تم التنويه داخل الكود عن السطر المسئول
'تم هذا الكود في 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


09-11-2017 10:51 مساء
مشاهدة مشاركة منفردة [3]
ناصر سعيد1
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
استدعاء بمعيارين     او بدون معيار
 
'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرطين
'وكذلك الاستدعاء بدون شرط
'وقد تم التنويه داخل الكود عن السطر المسئول
'تم هذا الكود في 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


06-02-2018 01:28 مساء
مشاهدة مشاركة منفردة [4]
تاج الدين
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 01-02-2018
رقم العضوية : 4153
المشاركات : 38
الجنس : ذكر
تاريخ الميلاد : 4-11-66
قوة السمعة : 46
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
شكرا لك استاذ  ياسر علي المجهود الرايع
 


06-02-2018 11:49 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10432
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36232
عدد الإجابات: 247
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
تسلم أخي العزيز تاج الدين ..مشكور على مرورك بالموضوع
 


17-02-2020 11:27 مساء
مشاهدة مشاركة منفردة [6]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 271
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
متاااااااااااااااااااااااااااااااااااااااااابع جداً لهذا الموضوع ويا رب ينفع مع حالتي هذه




الكلمات الدلالية
مطلوب ، اضافه ، لكود ، ترحيل ، بالمصفوفات ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 12:49 صباحا