ترحيل اعمدة معينة

[علي عبد المنعم]

برجاء المساعدة في ترحيل اعمدة معينة كما موضح في الملف

كود ترحيل اعمدة معينة.rar

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

جرب هذا الماكرو

Sub salim()
Dim Sh1, Sh2 As Worksheet
Dim lr1%, ro%, i%

Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2")
lr1 = Sh1.Cells(Rows.Count, "a").End(3).Row
ro = 3
Sh2.Range("C" & ro & ":i" & 500).ClearContents
    For i = 2 To lr1
            With Sh2.Cells(ro, 3)
             .Value = Sh1.Cells(i, 2)
             .Offset(0, 2) = Sh1.Cells(i, 2).Offset(0, 4)
             .Offset(0, 6) = Sh1.Cells(i, 2).Offset(0, 8)
            End With
         ro = ro + 2
   Next
End Sub