نسخ شيتات

[محسن33]

السلام عليكم

ارجو التكرم على مساعدتى فى

كيف يمكن  نسخ  البيانات من SHEET2

الى البيانات في شيت1 بشرط ان يندرج كل عميل البيانات الخاصة به

بمعنى جميع بيانات العجيل تحت بعضها علما بان عدد العملاء كبير

في انتظار الرد

 

 

نسخ شيتات.xlsm

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

للعمل بشكل جيد يجب

1-ازالة الخلايا المدمجة (عدو الاكواد)

2-ترتيب الييانات كما في الملف المرفق (صفحة Source)

الكود اللازم

Option Explicit
Sub give_data_by_Order()
Rem =====>> Created By Salim Hasbaya On 30/6/2019
Dim i#, r#, Fix_ro, t#
Dim search_rg As Range
Dim rg_to_copy As Range
Dim m#: m = 2
Dim col As New Collection
Dim last_row#
last_row = Source_sh.Cells(Rows.Count, 1).End(3).Row
 For i = 1 To last_row
  On Error Resume Next
  If Source_sh.Range("e" & i) <> "" Then
  col.Add Source_sh.Range("e" & i).Value, Source_sh.Range("e" & i).Value
  End If
  Next
  On Error GoTo 0
 Target_sh.Range("A:E").ClearContents
For i = 1 To col.Count
 Set search_rg = Source_sh.Range("E:E").Find(col(i), after:=Source_sh.Cells(Rows.Count, "E"))
  r = search_rg.Row: Fix_ro = r
  If Not search_rg Is Nothing Then
   '===================
   Do
      Set rg_to_copy = _
      Source_sh.Range("a" & r + 1, Source_sh.Range("a" & r + 2).End(4).Resize(, 4))
      Target_sh.Cells(m, 5) = search_rg.Value & " (" & t + 1 & ")"
      t = t + 1
    rg_to_copy.Copy _
    Target_sh.Cells(m, 1)
    m = m + rg_to_copy.Rows.Count + 1
    Set search_rg = Source_sh.Range("E:E").FindNext(search_rg)
    r = search_rg.Row
     If r = Fix_ro Then Exit Do
Loop
   
   '=======================
  End If
  t = 0
Next

End Sub

الملف مرفق

 

 

 

Copy_Data_Please.xlsm