ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات (كود حصري)

[ناصر سعيد]

رائعة النابغه ياسر خليل في الترحيل بالمصفوفات
ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات

(كود حصري)
https://youtu.be/ndC28IqkkBw

** من يريد دعمي فليقم بالاشتراك في القناة وعمل لايك للفيديوهات

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

رابط الملف

https://www.file-upload.com/ablfo2nqpekx

[ناصر سعيد]

Option Explicit

Sub Test()
'متغيرات
    Dim arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long
'اسم شيت المصدر واسم الخليه الاولى منه
    arr = Sheets("Sheet1").Range("A3").CurrentRegion.Value
    
    'الأعمدة المطلوب الترحيل إليها
    cr = Array(3, 5, 9)
    
    'أرقام الأعمدة المطلوب ترحيلها
    For Each i In Array(2, 6, 10)
    
    'اسم شيت الهدف ورقم صف صفحة الهدف
        Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
        j = j + 1
    Next i
End Sub

سحر الاكواد

[ناصر سعيد]

لو تكرمت يا استاذ ياسر

نريد ان يتم الترحيل بشرط معين في عمود معين ... مثال كلمه ناجح .. ناج*

 

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

بارك الله فيك أخي العزيز ناصر

بالنسبة لطلبك تم تناوله في فيديو سابق على الرابط التالي (يمكن إضافة شروط أو إضافة علامة النجمة للنص المطلوب كشرط ليكون أعم

 

[ناصر سعيد]

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

للنابغه ياسر خليل

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
    
    'متغير اسم ورقة المصدر
    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 "*" & "P" & "*" 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("Names", "Marks", "Status")
   
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها
    Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
End Sub

 

[ناصر سعيد]

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

 

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

ملف الكود السابق

[ناصر سعيد]

هل هذا السطر

 arr = Sheets("Sheet1").Range("A3").CurrentRegion.Value

يغني عن

    'متغير اسم ورقة المصدر
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
        'متغير اسم ورقة المصدرومدى البيانات بها
    arr = Sheets("Sheet1").Range("A2:C" & lr).Value

جزاك الله خيرا

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

نعم أخي ناصر 

ولكن لابد أن تكون متأكد أن الضغط على Ctrl + A من لوحة المفاتيح سيحدد النطاق المطلوب العمل عليه بشكل صحيح لكي لا تحدث مشاكل

أو يمكنك الاعتماد على الطريقة الثانية فهي أضمن وأفضل إذا لم تكن متأكد من النطاق الحالي 

[ناصر سعيد]

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

درر .. يجب الاحتفاظ بها

• مشاركات

 

قام بنشر الان · ارسل تقرير عن المشاركه

درر ...ترحيل اعمده معينه لاعمده اخرى في شيت اخر معينه

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

 

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

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

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

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

أرجو أن يستفيد الأخوة الذين يريدون التعلم من القناة على اليوتيوب ، والرجاء عمل اشتراك في القناة حيث أن ذلك يدعمني بشكل كبير

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

[ناصر سعيد]

الاستاذ الكبير ياسر خليل

بعد التحيه

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

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

أخي العزيز ناصر ..

بعد وضع النتائج في نطاق معين ..على سبيل المثال إذا كانت النتائج تبدأ في الخلية G1 .. يمكنك الاعتماد على النطاق بالشكل التالي

الإشارة لورقة العمل + أول خلية بالنطاق أو أي خلية داخل النطاق الذي يحتوي النتائج ثم استخدام خاصية CurrentRegion بهذا الشكل

With Sheets("Sheet1").Range("G1").CurrentRegion

..............


End With

مكان النقاط في الكود يوضع سطر بسيط جداً للتسطير بهذا الشكل

.Borders.Value=1

ولإلغاء التسطير استبدل الرقم 1 في السطر السابق بالقيمة صفر ..

أرجو أن يفيدك الرد إن شاء الله

[ناصر سعيد]

تعطي الخطا الاصفر الاتــي

===========

جزاك الله خيرا استاذ ياسر

للهم في هذا اليوم المبارك
اجعله لأعز الـــناس عندي
يوما مبـــــــــــــــــــــــاركا
فيه الدعوة لا تــــــــــــــرد
وهبه رزقا لا يعـــــــــــــــد
وافتح له باب في الجنة لا يسد
واحشره في زمرة سيدنا محمد صلى الله عليه وسلم

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

[ناصر سعيد]

جزاك الله خيرا

اتت بخط اصفر في مكان اخر

 

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

ارفق الملف الذي فيه المشكلة للإطلاع عليه .. حيث أن الصورة غير معبرة بشكل كامل عن المشكلة خصوصاً أن السطر غير ظاهر بشكل كامل

وعندما يظهر معك خطأ يفضل توضيح رسالة الخطأ التي تظهر لك قبل النقر على كلمة Debug

[ناصر سعيد]

تفضل المرفق

هذا الملف به الكود ..

 

بالحــــدود.rar

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

هل تريد تسطير النطاق بالكامل أم كل عمود على حدا .. عموماً جرب السطر التالي بعد السطر الذي يجلب البيانات من ورقة المصدر لورقة الهدف

Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1

 

[ناصر سعيد]

تم الغاء هذا السطر ووضع السطر الذي تفضلتم به

والاحظ السطر الملغى كان فيه الاندكس وتم الغاؤه وعمل الكود وتم تسطير الاعمده فقط

ثانيا نريد تسطير النطاق بالكامل

  ' Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)

 

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

عمل الكود مره واحده تمام ولم يات بتائج المرات الاخرى

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

لا يتم إلغاء السطر Index فهو يجلب النتائج وبعدها سطر آخر يتم تسطير النتائج به ..

[ناصر سعيد]

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

معلش فيه لازم عشان الكود يكون كثير الاستعمال والسهوله للجميع

لابد من سطر يمسح البيانات السابقه

عشان يضع البانات الجديه على نضيف  لان ممكن البيانات المرحله تتغي تقل في صفوفها فتظل البيانات القديمه ودي مشكله

ولاتنسانا في تسطير المدى كله

جزاك الله خيرا

 

[ناصر سعيد]

الكود بعد اضافة ميزة تسطير الاعمده المرحل اليها

Option Explicit
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير
'تم هذا الكود في 6/5/2017
Sub Test()
'متغيرات
    Dim arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long
    Dim lr      As Long
 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 = 1
        j = j + 1
    Next i
End Sub

 

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

بارك الله فيك وجزاك الله خيراً

يفضل في الأكواد بالفعل وضع أسطر لمسح محتويات النطاق الذي سيحوي النتائج الجديدة .. وهذا أمر لا يتطلب الكثير حيث يمكن وضع أسطر قبل الكود تقوم بالمسح وإزالة الحدود ... كما وضحت 

وبعد وضع النتائج يتم وضع سطر يقوم بالتسطير

تقبل تحياتي

[ناصر سعيد]

24 دقائق مضت, ياسر خليل أبو البراء said:

 وهذا أمر لا يتطلب الكثير حيث يمكن وضع أسطر قبل الكود تقوم بالمسح وإزالة الحدود ... كما وضحت 

وبعد وضع النتائج يتم وضع سطر يقوم بالتسطير

سهلها اكثر الله يسهلها عليك

 

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

أخي العزيز ناصر

أنا لا أدري بالضبط شكل المخرجات المطلوبة .. هل الأعمدة الغير متجاورة في النتائج هي المطلوب تسطيرها فقط أم أن نطاق النتائج بالكامل سواء كانت في الأعمدة المتجاورة أو غير المتجاورة هي المطلوبة؟

أعطيتك الدليل ببساطة تشير لورقة العمل ثم النطاق ثم تضع كلمة Borders.Value وبعدها علامة يساوي وتضع القيمة 1 للتسطير والقيمة 0 لإزالة التسطير .. كل ما عليك هو تحديد النطاق المطلوب

حاول وإن شاء الله تفلح بالأمر .. وفقك الله لما يحبه ويرضاه