اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

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

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

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

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

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

قام بنشر

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

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

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

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

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

  • أفضل إجابة
قام بنشر

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

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

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

ScreenRecorderProject7.gif.9ddd45c6a631a00d5df8976b37c7cfb4.gif

جرب هدا 

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

  • Like 2
  • Thanks 2
  • 2 weeks later...
قام بنشر

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

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

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

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

  • Like 1
  • Thanks 1

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information