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

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
أحمد يوسف ali mohamed ali-- لا تميز خلال هذه الفترة YasserKhalil تعديل عرض الأرقام كنسبة مئوية بالليست بوكس داخل الفورم اكسيل اسئله واجابات


اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا


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

Preview




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

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



09-11-2017 12:02 صباحا
ناصر سعيد1
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 627
الاعجاب : 3
 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
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 627
الاعجاب : 3
 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


أثارت هذه المشاركة إعجاب: ali mohamed ali،



09-11-2017 10:31 مساء
مشاهدة مشاركة منفردة [2]
ناصر سعيد1
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 627
الاعجاب : 3
 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
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس : ذكر
تاريخ الميلاد : 2-2-1990
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 627
الاعجاب : 3
 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]
تاج الدين
menu_open
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 01-02-2018
رقم العضوية : 4153
المشاركات : 28
الجنس : ذكر
تاريخ الميلاد : 4-11-66
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 32
الاعجاب : 2
 offline 
look/images/icons/i1.gif مطلوب اضافه لكود ترحيل بالمصفوفات
شكرا لك استاذ  ياسر علي المجهود الرايع
 




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

أثارت هذه المشاركة إعجاب: ali mohamed ali،



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

أثارت هذه المشاركة إعجاب: YasserKhalil،





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
اضافه جمله لكود بدون خطأ ابوحنين
4 1074 karwan
اضافه المسلسل لكود ناصر سعيد1
10 1789 ناصر سعيد1

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


 








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

الساعة الآن 04:26 صباحا

أعلن هنا
أعلن هنا
أعلن هنا