إستدعاء بيانات من ورقة إلى أخرى إعتمادا على رقم

[سعيد بيرم]

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

طبتم وطاب ممشاكم وتبوئتم جميعا من الجنة منزلا

ورزقنا جميعا من حيث لا نحتسب

لدى فى هذا المرفق ورقتى عمل أحدهما " المصدر" والأخرى " الهدف 

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

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

والسؤال كبف يمكن إستدعاء بيانات الجدوال من الورقة المصدر الى ورقة الهدف إعتماداً على رقم الموظف المدون بالخلية B5 فى الورقة الهدف

فهل من ذلك سبيل بإنشاء كود VBA  لتحقيق ذلك ****** برجاء الإطلاع على المثال المرفق

شكرا جزيلا مقدما وجزاكم الله خيرا

 

جلب بيانات اعتمادا على رقم الموظف.xlsm

[محمد هشام.]

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

Option Explicit
Sub Copier_tbl_Employe()
 Dim Code As String, lastrow As Long, n As Boolean
    Dim WS As Worksheet, dest As Worksheet
    Dim ColB As Variant, i As Long, tmp As Long

    Set WS = ThisWorkbook.Sheets("المصدر")
    Set dest = ThisWorkbook.Sheets("الهدف")
    tmp = 16: Code = dest.[B5].Value
    
    If Code = "" Then: MsgBox "الرجاء إدخال رقم الموظف", vbExclamation: Exit Sub

    lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    ColB = WS.Range("B1:B" & lastrow).Value
    n = False

    For i = 1 To UBound(ColB)
        If ColB(i, 1) = Code Then
            n = True
            Exit For
        End If
    Next i

    Application.ScreenUpdating = False
    If n Then
        With dest.Range("A5:I20")
            .UnMerge
            .ClearContents
        End With

       WS.Range("A" & i & ":I" & i + tmp).Copy
        With dest.Range("A5")
            .PasteSpecial Paste:=xlPasteAll
        End With
    Else
    MsgBox "لم يتم العثور على رقم الموظف : " & Code, vbExclamation
    End If

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

 

جلب بيانات اعتمادا على رقم الموظف.xlsm

تم تعديل الخميس at 00:30 بواسطه محمد هشام.

[سعيد بيرم]

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

شكرا جزيلا لإهتمامكم البالغ أخى محمد

تمت الإفادة بحول الله تعالى 

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