احتاج ماكرو لتنفيذ عملية بحث ونسح ولصق

[Adnan mushtaha]

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

اخواني الاعزاء تحيه طيبه وبعد

احتاج ماكرو ينفذ التالي:

كتابة رقم بطاقة التعريف في شيت 2

البحث عن رقم بطاقة تعريف في شيت1

ينسخ جميع الخلايا في الصف الموازي للرقم في شيت 2

test.xlsx

[حسين مامون]

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lr, x
Dim rng
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
Set rng = ws2.Range("c3")
lr = ws1.Cells(Rows.Count, 2).End(3).Row
For x = 2 To lr
   If ws1.Cells(x, 2) = rng Then
   ws1.Cells(x, 1).Resize(1, 4).Copy
          ws2.Range("b7").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        Application.CutCopyMode = False
        Exit For
     End If
Next x
End Sub

جرب المرفق

test (2).xlsm

[Adnan mushtaha]

بارك الله فيك و جزاك الله خيرا

عمل جبار💥

[سليم حاصبيا]

بعد اذن الاخ حسين

لا حاجة للحلقات التكرارية التي ترهق البرنامج (في حال البيانات الكثيرة   أكثر من 500 صف)
 في حين يمكن وضع اليد مباشرة على الخلية المطلوبة بواسطة الدالّة Find

Option Explicit
Sub find_me()
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet
  Dim RG1 As Range

  Set ws1 = Sheets("ورقة1")
  Set ws2 = Sheets("ورقة2")
  ws2.Cells(7, 2).Resize(4).ClearContents
  
  Set RG1 = ws1.Range("A1").CurrentRegion.Columns(2). _
   Find(ws2.Range("C3"), Lookat:=1)

If Not RG1 Is Nothing Then
 ws1.Cells(RG1.Row, 1).Resize(, 4).Copy
 ws2.Cells(7, 2).PasteSpecial (12), Transpose:=True
End If
Application.CutCopyMode = False
ws2.Cells(3, 3).Select
End Sub

 

كما يمكن عمل ذلك بمعادلة بسيطة

=OFFSET(INDEX(ورقة1!$B$2:$B$9,MATCH($C$3,ورقة1!$B$2:$B$9,0)),,ROWS($A$1:A1)-2)

الملف مرفق

Adnan.xlsm

[سليم حاصبيا]

اذا كنت قد فهمت عليك ما تريده 

لا حاجة للكود 

Adnan mushtaha.xlsx