مساعدة في ترحيل البيانات

[ازهر عبد العزيز]

السلام عليكم ,,,,,

احتاج ترحيل بيانات من الورقة 2 الى الورقة 3 

tset20.xlsm

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

التنسيقات بهذا الشكل و الألوان الباهرة تثقل الملف دون حاجة لها

الكود

Option Explicit

Sub Tansfer_data()
Dim Tabl As Range
Dim m%, Ro%, x%, k%, LA%
Dim B_rg As Range
Set Tabl = Source.Range("A5").CurrentRegion
Ro = Tabl.Rows.Count
If Ro = 1 Then Exit Sub
Set B_rg = But.Range("A1").CurrentRegion
  If B_rg.Rows.Count > 1 Then
  B_rg.Offset(1).Resize(B_rg.Rows.Count - 1) _
 .Interior.ColorIndex = xlNone
End If
 Set Tabl = Tabl.Offset(1).Resize(Ro - 1)
 x = But.Cells(Rows.Count, 4).End(3).Row + 1
  But.Range("D" & x).Resize(Ro - 1, Tabl.Columns.Count).Value = _
 Tabl.Value
 m = Application.CountA(But.Range("D:D"))
 m = But.Cells(m, 1).Offset(-Ro + 1).Row + 1
 For k = 1 To 3
 But.Cells(m, k) = Source.Cells(k, 2)
 Next
 
  LA = But.Cells(Rows.Count, 1).End(3).Row
  If LA > 2 Then
    But.Range("A2:C" & LA).Resize(, 3) _
    .SpecialCells(2).Interior.ColorIndex = 35
  End If
  Tabl.ClearContents
End Sub

الملف مرفق

Azhar.xlsm

[ازهر عبد العزيز]

شكرا جزيلا استاذ سليم حاصبيا وهو المطلوب جزاك الله عني كل  خير