كود استدعاء حسب النموذج المرفق

[صباح2024]

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

عندي نموذج مرفق 

محتاج كود استدعاء حسب الاسم

 

كود استدعاء بيانات.xlsm

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

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

الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$B$6" Then
        Application.ScreenUpdating = False
        Dim wsSource As Worksheet
        Dim wsTarget As Worksheet
        Dim nameToFind As String
        Dim foundCell As Range
        Dim data As Variant
        
        Set wsSource = ThisWorkbook.Sheets("السجل")
        Set wsTarget = ThisWorkbook.Sheets("استدعاء")
        nameToFind = wsTarget.Range("B6").Value
        
        Set foundCell = wsSource.Range("B:B").Find(What:=nameToFind, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not foundCell Is Nothing Then
            data = wsSource.Range(foundCell.Offset(0, 1), foundCell.Offset(0, 10)).Value
            wsTarget.Range("A9:I9").Value = data
            
            data = wsSource.Range(foundCell.Offset(0, 10), foundCell.Offset(0, 19)).Value
            wsTarget.Range("A12:I12").Value = data
            
            data = wsSource.Range(foundCell.Offset(0, 19), foundCell.Offset(0, 28)).Value
            wsTarget.Range("A15:I15").Value = data
            
            data = wsSource.Range(foundCell.Offset(0, 28), foundCell.Offset(0, 38)).Value
            wsTarget.Range("A18:I18").Value = data
        Else
            MsgBox "الاسم غير موجود في السجل."
        End If
        
        Application.ScreenUpdating = True
    End If
End Sub

الملف

كود استدعاء بيانات1.xlsm

[صباح2024]

مضبوط

تسلم

100 %