كود ترحيل بناء علي قائمة منسدلة

[2saad]

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

أتقدم بخالص الشكر لكل الاعضاء لاني تعلمت منهم الكثير في هذا المنتدي الجليل

محتاج كود يقوم بترحيل البيانات الملونة باللون الأصفر من sheet1  و sheet2  و sheet3 الي شيت ( saad ) بناء علي القائمة المنسدلةN7

ولكم جزيل الشكرترحيل الدرجات.xlsm

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته

حسب فهمي لطلبك 

الكود

Sub FilterAndCopyData()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, wsDest As Worksheet
    Dim searchValue As String
    Dim rng As Range, cell As Range
    Dim lastRow As Long, destRow As Long
    Dim serialNumber As Long
    Set ws1 = ThisWorkbook.Sheets("SHEET1")
    Set ws2 = ThisWorkbook.Sheets("SHEET2")
    Set ws3 = ThisWorkbook.Sheets("SHEET3")
    Set wsDest = ThisWorkbook.Sheets("SAAD")
    wsDest.Range("C13:R" & wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row).ClearContents
    searchValue = wsDest.Range("N7").Value
    destRow = 13
    serialNumber = 1
    For Each ws In Array(ws1, ws2, ws3)
        lastRow = ws.Cells(ws.Rows.Count, "P").End(xlUp).Row
        Set rng = ws.Range("P12:P" & lastRow)
        For Each cell In rng.Cells
            If cell.Value = searchValue Then
                wsDest.Cells(destRow, "C").Value = serialNumber
                wsDest.Cells(destRow, "F").Value = cell.Offset(0, -10).Value
                wsDest.Cells(destRow, "J").Value = cell.Offset(0, -6).Value
                wsDest.Cells(destRow, "L").Value = cell.Offset(0, -4).Value
                wsDest.Cells(destRow, "M").Value = cell.Offset(0, -3).Value
                wsDest.Cells(destRow, "P").Value = cell.Value
                wsDest.Cells(destRow, "Q").Value = cell.Offset(0, 1).Value
                wsDest.Cells(destRow, "R").Value = cell.Offset(0, 2).Value
                destRow = destRow + 1
                serialNumber = serialNumber + 1
            End If
        Next cell
    Next ws
End Sub

الملف

ترحيل الدرجات1.xlsm

 

تم تعديل أكتوبر 4 بواسطه عبدالله بشير عبدالله

[2saad]

الله يبارك فيك وأكثر الله من أمثالك

[عبدالله بشير عبدالله]

وفيك بارك الله

تم تعديل أكتوبر 4 بواسطه عبدالله بشير عبدالله

[2saad]

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

[عبدالله بشير عبدالله]

  الملف السابق به تعديل المدى  في الشيتات الثلاتة الاولى الكود  السابق  يبذأ من الصف 12 والصحيح انه 9

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

ترحيل الدرجات1.xlsm

 

 

 

[2saad]

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