محتاج كود استخراج بيانات عمود بناء على الاستعلام برقم العمود

[ehabaf2]

السلام عليكم الاخوة الافاضل الكرام

محتاج كود vba  يقوم بنسخ العمود من النطاق الاصل a:z  حيث كل عمود له رقم فى السطر الثالثل و ينقله الى نطاق استخراج البيانات من ap:bo  بشرط يتم وضع رقم العمود المراد استخراجه فى السطر 3

مرفق ملف للتوضيح

الف الف شكر لحضراتكم على جهودكم 

استخراج الاعمةدة.xlsm

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

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

طلبك غير واضح بالنسبة لي 

هل تريد اخراجها بنفس الترتيب

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

اكنب في  AB:BO  صفين او ثلاتة النتائج المتوقعة 

[محمد هشام.]

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

كما سبق الدكر من الأستاد @عبدالله بشير عبدالله   طلبك غير واضح إظافة أن أرقام الأعمدة على الملف تتواجد في الصف 3 ليس 2 

مجرد تخمين ربما تقصد جلب بيانات العمود بشرط إدخال  قيمة رؤوس الأعمدة (رقم العمود)

جرب هدا 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim OnRng As Variant, tmp As Variant, lastRow As Long, a As Long, Clé As String
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    
    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, WS.Range("AQ3:BO3")) Is Nothing Then
        
        lastRow = WS.Columns("A:Z").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        OnRng = WS.Range("A4:Z" & lastRow).Value
        tmp = WS.Range("A3:Z3").Value
        Clé = Target.Value
        
        Application.ScreenUpdating = False
         
         If IsEmpty(Target.Value) Then
            WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)).ClearContents
        Else
            For a = 1 To UBound(tmp, 2)
                If tmp(1, a) = Clé Then
                    With WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column))
                        .ClearContents
                        .Value = Application.Index(OnRng, 0, a)
                    End With
                    Exit For
                End If
            Next a
        End If
        
        If a > UBound(tmp, 2) Then Target.ClearContents: MsgBox "لم يتم العثور على " & _
           Target.Value & " في قاعدة البيانات", vbExclamation, "إنتبـــاه"
    End If
    Application.ScreenUpdating = True
End Sub

 

استخراج الاعمدة.xlsm

[ehabaf2]

السلام عليكم استاذنا الفاضل @محمد هشام.

اولا اعتزر للتاخر فى الرد لظروف شخصية

لا اجد من كلمات الشكر تفى حقك الف الف شكر لحضرتك الكود رائع و ينفذ المطلوب

زادك الله من علمه و فضله و رفع قدرك