ترحيل بيانات من ..... الي

[commandos1975]

اضافة ماكرو لنسخ الاسماء من الورقة السابقة الي الورقة الحاليه علي حسب من    الي    المكتوبه

aaaa.xls

[حسين مامون]

هذه محاولة ان لم يعجبك انتظر احد الاساتدة ليجيبك

Option Explicit

Sub copy_list()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lr, x, r
Dim rng1
Dim rng2
Application.ScreenUpdating = False
Set ws1 = Sheets("main")
Set ws2 = Sheets("list")
With ws2
.Range("b6:c10000").ClearContents
Set rng1 = .Range("g5")
Set rng2 = .Range("i5")
If rng1 = "" Or rng2 = "" Then Exit Sub
r = 6
lr = ws1.Cells(Rows.Count, "c").End(xlUp).Row
For x = 3 To lr
Select Case ws1.Cells(x, "c").Value2: Case rng1 To rng2
 .Range("b" & r).Resize(1, 2).Value = ws1.Cells(x, "c").Resize(1, 2).Value
 r = r + 1
 End Select
Next x
End With
Application.ScreenUpdating = True
End Sub

 

aaaa.xlsm

تم تعديل سبتمبر 7, 2019 بواسطه حسين مامون

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

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

هذا الكود

Option Explicit

Sub copy_Form_to()

Dim M As Worksheet: Set M = Sheets("Main")
Dim L As Worksheet: Set L = Sheets("list")
If Not IsNumeric(L.Range("g5")) Or L.Range("g5") = 0 Then Exit Sub
If Not IsNumeric(L.Range("I5")) Or L.Range("I5") = 0 Then Exit Sub
Dim lrM%:         lrM = M.Cells(Rows.Count, 3).End(3).Row
Dim RgC As Range:   Set RgC = L.Range("C6:C35")

L.Range("b5").CurrentRegion.Offset(1).ClearContents
Dim My_Min: My_Min = Application.Min(L.Range("g5:I5"))
Dim My_Max: My_Max = Application.Max(L.Range("g5:I5"))
If My_Max > lrM - 2 Then My_Max = lrM - 2
Dim t%, K%
Dim r%, c%, X%
r = 6: c = 3
My_Min = Int(Abs(My_Min)): My_Max = Int(Abs(My_Max))
 For t = My_Min To My_Max
 On Error Resume Next
  X = M.Range("c:c").Find(t, lookat:=1).Row
If Err.Number Then Err.Number = 0: GoTo next_t
   If X Then
     K = K + 1
   If K = (RgC.Rows.Count) * 2 + 1 Then Exit For
    L.Cells(r, c - 1) = t: L.Cells(r, c) = M.Cells(X, 4)
    r = r + 1
  If K = RgC.Rows.Count Then r = 6: c = c + 2

   End If
next_t:
  Next
End Sub

الملف مرفق

 

aaaa.xlsm

[احمد بدره]

بارك الله فيك أستاذ سليم

[commandos1975]

بارك الله فيك 

 

[أحمد يوسف]

السلام عليكم أستاذ commandos1975 أرى انك لم تقم بالضغط على علامة الإعجاب للأساتذة على تقديم الإجابات الرائعة لخل مشكلتك ومساعدتك

على الرغم ان الإجابة اعجبتك

أعتقد ان هذا اقل ما تقدمه اعترافا بجميل كل هؤلاء الأساتذة عليك في حل مشكلتك ان تقوم بالضغط لهم وابداء الإعجاب بهذه الحلول