مساعدة فى عمل كود لجعل البيانات بشكل راسى

[hitech]

اريد كود بحيث عندما يتم اختيار اسم احمد مثلا يتم استدعاء بياناته من ورقة 1 الى ورقة 2 بشكل راسى وهكذا مع باقى الاسماء

شيت 121.xlsm

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

بدل اعطاء البيانات والتفتيش عنها داخل الورقة 

اذكر الأعمدة المطلوب نقلها (مثلاً عامود B عامود C الخ.... )

[hitech]

المشكلة استاذنا انى مرتبط بالاسماء فى العمود r

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

أنا أفصد ارفام الأعمدة المطلوبة في شيت المصدر لا في شيت النتيجة

[hitech]

من العمود a الى العمود m استاذنا وتم رفع الملف مرة اخرى بعد ازالة الاعمدة المخفية

والشكل اللى عاوز اوصله واضح فى ورقة 2

شيت 121.xlsm

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

من العمود a الى العمود m هناك 13    عامود اي أعمده تريد منها

[hitech]

اريد الموظف احمد مثلا توضع بياناته اسفل بعض بمعنى من a3 حتى c9 ثم اسفله من d3 حتى f9 ثم اسفله من g3 حتى i8 ثم اسفله j3 حتى l8 وده يتم فى الورقة رقم 2 وفيه شكل موضح ومرفق تعديل يسيط للملف والف الف شكر على متابعة حضرتك استاذنا الغالى

شيت البصمة.xlsm

[hitech]

فى انتظار رد حضرتك استاذنا الغالى

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

1- تبديل اسماء الصفحات الى    Source  و   Targ  لجسن نسخ الكود ولصقه

الكود

Option Explicit

Sub get_data()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Dim s As Worksheet, T As Worksheet
Dim S_rg As Range, Find_rg As Range
Dim Nme$, i%
Dim RoT%, Ro%, m%: m = 3

Set s = Sheets("source"): Set T = Sheets("Targ")

Nme = T.Cells(1, 1)
RoT = T.Cells(Rows.Count, 1).End(3).Row
T.Range("A3").Resize(RoT, 3).Clear
If Nme = vbNullString Then GoTo End_Me

Set Find_rg = s.Columns("M").Find(Nme, lookat:=1)
If Not Find_rg Is Nothing Then
    Ro = Find_rg.Row + 2
    Set S_rg = s.Cells(Ro, 1).CurrentRegion
    
    For i = 1 To 10 Step 3
      S_rg.Cells(1, i).Resize(S_rg.Rows.Count, 3).Copy _
      T.Cells(m, 1)
      m = m + S_rg.Rows.Count
    Next
End If
If m > 3 Then
    With T.Range("A3").CurrentRegion
      .InsertIndent 1
      .Borders.LineStyle = 1
      .Font.Bold = True
      .Font.Size = 14
      .Interior.ColorIndex = 35
    End With
  
End If
End_Me:
  With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
  .CutCopyMode = False
  End With

End Sub

الملف مرفق

 

Basma Sh.xlsm

[hitech]

عمل رائع استاذ سليم اشكرك عليه جزاءاك الله كل خير واسف جدا جدا لتعب حضرتك معايا

[hitech]

استاذنا الكبير معلش حاولت اطبق الكود على شيت اخر لاقيت ان البيانات التى يتم نقلها اكبر مما هى عليها فى الشيت الاصلى

ولى طلب بسيط لو امكن ان البيانات التى يتم نسخها فى الورقة targ يا ريت تبدا من الخلية b3

واسف جدا لازعاج حضرتك مرة اخرى

Basma Sh.xlsm