نقل صف من صفحتين الى صفحة ثالثه

[فراس سعدي]

السلام عليكم ورحمة الله وبركاته

بالمرفق ملف مكون من ثلاث صفحات احتاج نقل صف من كل صفحة الى الصفحة الثالثة صف من الصفحة الاولى وصف من الصفحة الثانية للصفحة الثالثة 

وحسب الصفوف بالصفحات الاولى والثانية من حيث العدد وجعلت الصفحة الاولى باللون الاصفر والثانية باللون الاحمر للسهوله

ناخذ صف من الصفحة الاولى بالون الاصفر الى اول سطر بالصفحة الثالثة و

ناخذ صف من الصفحة الثانية باللون الاحمر الى ثاني سطر من الصفحة الثالثة 

وهكذا حسب الصفوف في كل الصفحات 

nath2.rar

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

Sub Crazy_Translate()
Dim ws1, ws2, ws3 As Worksheet
Dim lr1, lr2, m, n As Integer
Application.ScreenUpdating = False

 Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2"): Set ws3 = Sheets("sheet3")
 ws3.Cells.ClearContents
 lr1 = ws1.Cells(Rows.Count, 1).End(3).Row
 lr2 = ws2.Cells(Rows.Count, 1).End(3).Row
 For i = 1 To lr1
   ws1.Range("a" & i).Resize(1, 10).Copy
  ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteAll: m = m + 2
   ws2.Range("a" & i).Resize(1, 10).Copy
   ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteAll: n = n + 2
   Next
   ws3.Columns.AutoFit
   Application.ScreenUpdating = True
End Sub

جرب هذا الكود

 

[فراس سعدي]

السلام عليكم 

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

123.rar

تم تعديل نوفمبر 17, 2016 بواسطه فراس سعدي

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

4 ساعات مضت, فراس سعدي said:

السلام عليكم 

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

123.rar

تم التعديل على الكود

Sub Crazy_Translate()
Dim ws1, ws2, ws3 As Worksheet
Dim lr1, lr2, m, n As Integer
Application.ScreenUpdating = False

 Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2"): Set ws3 = Sheets("sheet3")
 ws3.Cells.Clear
 lr1 = ws1.Cells(Rows.Count, "j").End(3).Row
 lr2 = ws2.Cells(Rows.Count, "f").End(3).Row
 For i = 1 To lr1
  ws1.Range("j" & i).Copy
  ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
  ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteFormats: m = m + 2
  Next
 For k = 1 To lr2
   ws2.Range("f" & k).Copy
   ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteValues
   ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteFormats: n = n + 2
 Next
   ws3.Columns.AutoFit
   Application.ScreenUpdating = True
End Sub

 

 

[فراس سعدي]

11 دقائق مضت, سليم حاصبيا said:

تم التعديل على الكود

Sub Crazy_Translate()
Dim ws1, ws2, ws3 As Worksheet
Dim lr1, lr2, m, n As Integer
Application.ScreenUpdating = False

 Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2"): Set ws3 = Sheets("sheet3")
 ws3.Cells.Clear
 lr1 = ws1.Cells(Rows.Count, "j").End(3).Row
 lr2 = ws2.Cells(Rows.Count, "f").End(3).Row
 For i = 1 To lr1
  ws1.Range("j" & i).Copy
  ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
  ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteFormats: m = m + 2
  Next
 For k = 1 To lr2
   ws2.Range("f" & k).Copy
   ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteValues
   ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteFormats: n = n + 2
 Next
   ws3.Columns.AutoFit
   Application.ScreenUpdating = True
End Sub

 

 

كلماتي قليله في حقك لكن ادعولك من ظهر غيب يا مبدع شكرا لك اخي الكريم