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

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


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





الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)

اخواني الأفاضل بعد السلام عليكم ورحمة الله وبركاته محتاج كود يرحلي الأعمدة المحددة باللون الأحمرمن شيت data الي شيت m ..


موضوع مغلق

الصفحة 1 من 3 < 1 2 3 > الأخيرة »


06-11-2021 05:26 مساء
saad mohamed
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-08-2019
رقم العضوية : 14161
المشاركات : 78
الجنس : ذكر
تاريخ الميلاد : 12-5-1973
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 65
 offline 

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

 

محتاج كود يرحلي الأعمدة المحددة باللون الأحمرمن شيت  data الي شيت mohaolon بناء علي القائمة المنسدلة الموجودة في h6

 

ولكم جزيل الشكر ووافر الاحترام


لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  سها.xlsm   تحميل xlsm مرات التحميل :(57)
الحجم :(1621.194) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
وأخيراً إليك الكود النهائي (وأعتقد أنه لن يكون لديك صبر لقراءة المشاركات السابقة وستنتقل مباشرةً لنسخ الكود النهائي) .. وهتقول في سرك (بلاش صداع يا مستر)

Sub Test()
    Dim a, b, ws As Worksheet, sh As Worksheet, sCondition As String, lr As Long, i As Long, k As Long, ii As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("data")
        Set sh = ThisWorkbook.Worksheets("moholon")
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        sCondition = sh.Range("H6").Value
        If sCondition = "" Then MsgBox "Select From Drop-Down First", vbExclamation: Exit Sub
        a = ws.Range("A3:R" & lr).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,4,5,9,10,11,12,13,14,15,17}])
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        For i = LBound(a, 1) To UBound(a, 1)
            If a(i, 13) = sCondition Then
                k = k + 1
                For ii = LBound(a, 2) To UBound(a, 2)
                    b(k, ii) = a(i, ii)
                Next ii
                b(k, 1) = k
            End If
        Next i
        With sh.Range("A10")
            .Resize(Rows.Count - 9, UBound(b, 2)).ClearContents
            .Resize(k, UBound(b, 2)).Value = b
        End With
    Application.ScreenUpdating = True
End Sub
عرض الإجابة




07-11-2021 04:54 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)
السلام عليكم أخي الكريم سعد
هذا ليس أول موضوع تطلب فيه كود للترحيل ، ولا يوجد أي تقدم على الإطلاق ولا أي محاولات منك للوصول للمطلوب. وهذا ليس الهدف من المنتدى ، حيث أن الهدف أن يرتقي المنتدى بالأعضاء.

عموماً سأقوم بوضع الكود ولكن ليس مرة واحدة ، وإنما سأقوم بشرح الكود على مراحل ليتعلم الأعضاء كيفية التعامل مع موضوع الترحيل لأن هذا الموضوع بالذات قد قتل بحثاً.

تفضل الكود التالي
Sub Test()
    Dim ws As Worksheet, sh As Worksheet, lr As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("data")
        Set sh = ThisWorkbook.Worksheets("moholon")
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        
    Application.ScreenUpdating = True
End Sub


هذا هو الهيكل العام للكود حيث في أول سطر الإعلان عن المتغيرات ، والمتغيرات يمكن اعتبارها بمثابة دليل أو اختصار لما سنتعامل معه ، فالمتغير ws يشير إلى ورقة البيانات الخام ، والمتغير sh يشير إلى الورقة التي سيتم الترحيل إليها ، والمتغير lr سنستخدمه لمعرفة رقم آخر صف به بيانات في ورقة البيانات data.

السطر الثاني سطر لإيقاف اهتزاز الشاشة وهو لتسريع الكود.

السطر الثالث والرابع أسطر لتعيين قيمة للمتغيرات الخاصة بورقة البيانات وورقة النتائج.

السطر الخامس لمعرفة رقم آخر صف به بيانات في ورقة البيانات data بناءً على العمود C (عمود الأسماء).

السطر السادس لإرجاع خاصية اهتزاز الشاشة في نهاية الكود.

07-11-2021 05:13 صباحا
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)
المرحلة الثانية: إليك الكود التالي
Sub Test()
    Dim a, b, ws As Worksheet, sh As Worksheet, sCondition As String, lr As Long, i As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("data")
        Set sh = ThisWorkbook.Worksheets("moholon")
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        
        Rem Second
        sCondition = sh.Range("H6").Value
        If sCondition = "" Then MsgBox "Select From Drop-Down First", vbExclamation: Exit Sub
        a = ws.Range("A3:R" & lr).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,4,5,9,10,11,12,13,14,15,17}])
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        For i = LBound(a, 1) To UBound(a, 1)
            Rem Code Here
        Next i
    Application.ScreenUpdating = True
End Sub



لاحظ أننا أضفنا المزيد من المتغيرات في سطر المتغيرات وهو المتغير a وسيكون لمصفوفة البيانات ، والمتغير b وسيكون لمصفوفة النتائج التي ستكون حسب الشرط الموضوع
والمتغير sCondition  متغير نصي سيتم تخزين قيمة الشرط الموجود في الخلية H6 (الموجودة في ورقة النتائج) ، والمتغير i سيستخدم لعمل حلقة تكرارية لمصفوفة البيانات (بمثابة عداد)

السطر الأول في المرحلة الثانية هو وضع قيمة للشرط والقيمة ستكون مساوية لقيمة الخلية H6 الموجودة في ورقة النتائج

السطر الثاني عمل اختبار لقيمة الشرط sCondition بحيث لو القيمة تساوي فراغ ، يظهر رسالة للمستخدم تفيد بأن يقوم بالاختيار من القائمة المنسدلة يتبعها جملة الخروج من الإجراء 

السطر الثالث تعيين قيمة المصفوفة للبيانات وهي قيمة النطاق بدايةً من الخلية A3 وحتى العمود R إلى نهاية البيانات بناءً على قيمة رقم آخر صف به بيانات lr

السطر الرابع إعادة هيكلة مصفوفة البيانات بحيث نتعامل مع الأعمدة المطلوبة وبنفس الترتيب في ورقة النتاج ، وتلاحظ هنا أرقام الأعمدة 
[{1,2,3,4,5,9,10,11,12,13,14,15,17}])

لكن لابد أن تلاحظ أن التعامل مع أرقام الصفوف وأرقام الأعمدة سيكون من خلال المصفوفة وليس من خلال ورقة العمل

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

السطر السادس عبارة عن بداية حلقة تكرارية بدايتها أول صف في مصفوفة البيانات ونهايتها آخر صف في مصفوفة البيانات

السطر السابع الانتقال للصف التالي داخل المصفوفة

وما بين السطر السادس والسابع سيتم إضافة الأكواد للتعامل مع كل صف داخل المصفوفة

07-11-2021 05:25 صباحا
مشاهدة مشاركة منفردة [3]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 277
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)
ما شاء الله تبارك الله حفظكم الله ورعاكم استاذنا... دائماً ما تتحفنا بدرر ابداعاتك جزاكم الله الفردوس الأعلى من الجنة اللهم آمين يارب العالمين 

07-11-2021 05:37 صباحا
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)
المرحلة الثالثة: إليك الكود
Sub Test()
    Dim a, b, ws As Worksheet, sh As Worksheet, sCondition As String, lr As Long, i As Long, k As Long, ii As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("data")
        Set sh = ThisWorkbook.Worksheets("moholon")
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        
        Rem Second
        sCondition = sh.Range("H6").Value
        If sCondition = "" Then MsgBox "Select From Drop-Down First", vbExclamation: Exit Sub
        a = ws.Range("A3:R" & lr).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,4,5,9,10,11,12,13,14,15,17}])
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        For i = LBound(a, 1) To UBound(a, 1)
        
            Rem Third
            If a(i, 13) = sCondition Then
                k = k + 1
                For ii = LBound(a, 2) To UBound(a, 2)
                    b(k, ii) = a(i, ii)
                Next ii
                b(k, 1) = k
            End If
            
        Next i
        
    Application.ScreenUpdating = True
End Sub


لاحظ في سطر المتغيرات أضفنا المتغير k وهو سيكون بمثابة عداد ، أي إذا تحقق الشرط وكانت القيمة في مصفوفة البيانات تساوي الشرط sCondition فإن العداد يزيد بمقدار واحد ، والمتغير الثاني هو ii وسيكون لعمل حلقة تكرارية لأعمدة مصفوفة البيانات

السطر الأول 
If a(i, 13) = sCondition Then

وهو عمل اختبار لنتأكد من أن القيمة الموجودة في صف المصفوفة في العمود رقم 13 داخل المصفوفة يساوي الشرط sCondition أم لا
لما الرقم 13 بالتحديد؟ لأنه بعد إعادة هيكلة مصفوفة البيانات واختيار أعمدة معينة كما وضحنا سابقاً أصبح عمود الشرط في مصفوفة البيانات هو رقم 13 وليس رقم 17 كما في ورقة العمل

السطر الثاني زيادة قيمة العداد k كما وضحنا بمقدار واحد ، وهو بمثابة رقم الصف داخل مصفوفة النتائج أي في أول مرة يتحقق الشرط نبدأ التعامل مع أول صف داخل مصفوفة النتائج

السطر الثالث بداية حلقة تكرارية للأعمدة داخل المصفوفة وذلك لتعبئة مصفوفة النتائج بنفس البيانات الموجودة في مصفوفة البيانات ، ولاحظ استخدام الرقم 2 مع UBound حيث الرقم 2 يشير لأعمدة المصفوفة

السطر الرابع يقوم بتعبئة مصفوفة النتائج حيث k هو رقم الصف في مصفوفة النتائج ، وii رقم العمود المطلوب التعامل معه .. ونقول أنها تساوي من مصفوفة البيانات رقم الصف i ونفس رقم العمود ii

السطر الخاس الانتقال للعمود التالي حتى يتم تعبئة جميع بيانات الصف الجديد في مصفوفة النتائج

السطر السادس لوضع الرقم المسلسل الجديد حسب قيمة المتغير k ، أي أن الترقيم في ورقة النتائج لا يتم التعامل معه في هذه الحالة حسب الترقيم الموجود في ورقة البيانات ، وإنما يتم الترقيم حسب تحقق الشرط من عدمه (خلاصة القول يتم الترقيم بشكل منفصل لعدد النتائج)

السطر السابع نهاية جملة الشرط والتي يتبعها جملة الانتقال لصف جديد ، حتى تتكرر نفس الخطوات ويتم اختبار الشرط وهكذا

07-11-2021 05:43 صباحا
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)
المرحلة الرابعة والأخيرة: إليك الكود التالي
Sub Test()
    Dim a, b, ws As Worksheet, sh As Worksheet, sCondition As String, lr As Long, i As Long, k As Long, ii As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("data")
        Set sh = ThisWorkbook.Worksheets("moholon")
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        
        Rem Second
        sCondition = sh.Range("H6").Value
        If sCondition = "" Then MsgBox "Select From Drop-Down First", vbExclamation: Exit Sub
        a = ws.Range("A3:R" & lr).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,4,5,9,10,11,12,13,14,15,17}])
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        For i = LBound(a, 1) To UBound(a, 1)
        
            Rem Third
            If a(i, 13) = sCondition Then
                k = k + 1
                For ii = LBound(a, 2) To UBound(a, 2)
                    b(k, ii) = a(i, ii)
                Next ii
                b(k, 1) = k
            End If
            
        Next i
        
        Rem Fourth
        With sh.Range("A10")
            .Resize(Rows.Count - 9, UBound(b, 2)).ClearContents
            .Resize(k, UBound(b, 2)).Value = b
        End With

    Application.ScreenUpdating = True
End Sub


هنا في المرحلة الأخيرة بعد أن قمنا بالتعامل مع البيانات داخل الذاكرة بشكل كامل ، نبدأ في وضع البيانات في ورقة النتائج
وهذا أمر واضح في الأسطر حيث أن السطر الاول نبدأ في التعامل مع الخلية A10 وهي أول خلية سنقوم بوضع النتائج فيها
ولكن وضع البيانات سيكون أمر مربك إذا وضعناها مباشرة ، لذا لابد أن نقوم أولاً بمسح النطاق من الخلية A10 بامتداد كل صفوف ورقة العمل وبامتداد الأعمدة بحيث تكون مساوية لعدد أعمدة مصفوفة النتائج وهو 13 كما في المثال ، وهذا ما يقوم به السطر الثاني

السطر الثالث والأخير وهو ما يهم الجميع وهو سطر النتائج وتكون النتائج بامتداد عدد صفوف المتغير k (حيث أننا استخدمنا المتغير كعداد فقط حينما يتحقق الشرط) ، وبامتداد عدد أعمدة مصفوفة النتائج وهو 13 كما في المثال وأخيراً يوضع في هذا النطاق النتائج النهائية

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

07-11-2021 05:47 صباحا
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif الدليل الشامل في أكواد الترحيل باستخدام المصفوفات (الترحيل من ورقة عمل لورقة عمل أخرى بشرط)
وأخيراً إليك الكود النهائي (وأعتقد أنه لن يكون لديك صبر لقراءة المشاركات السابقة وستنتقل مباشرةً لنسخ الكود النهائي) .. وهتقول في سرك (بلاش صداع يا مستر)

Sub Test()
    Dim a, b, ws As Worksheet, sh As Worksheet, sCondition As String, lr As Long, i As Long, k As Long, ii As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("data")
        Set sh = ThisWorkbook.Worksheets("moholon")
        lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
        sCondition = sh.Range("H6").Value
        If sCondition = "" Then MsgBox "Select From Drop-Down First", vbExclamation: Exit Sub
        a = ws.Range("A3:R" & lr).Value
        a = Application.Index(a, Evaluate("ROW(1:" & UBound(a, 1) & ")"), [{1,2,3,4,5,9,10,11,12,13,14,15,17}])
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        For i = LBound(a, 1) To UBound(a, 1)
            If a(i, 13) = sCondition Then
                k = k + 1
                For ii = LBound(a, 2) To UBound(a, 2)
                    b(k, ii) = a(i, ii)
                Next ii
                b(k, 1) = k
            End If
        Next i
        With sh.Range("A10")
            .Resize(Rows.Count - 9, UBound(b, 2)).ClearContents
            .Resize(k, UBound(b, 2)).Value = b
        End With
    Application.ScreenUpdating = True
End Sub


الصفحة 1 من 3 < 1 2 3 > الأخيرة »


الكلمات الدلالية
محتاج ، ترحيل ،


 










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

الساعة الآن 05:26 مساء