محتاج كود ترحيل

[2saad]

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

لو سمحت انا عايز يتم الترحيل من الشيت 1 و2 و3 في الأعمدة الملونة فقط الي شيت ( eman ) من العمود c10)

أنا حاولت بس معرفتش

ولكم جزيل الشكر

وكل عام وانتم بخيركل عام وانت بخير.xlsm

[خالد المصـــــــــــرى]

بالمعادلات

كل عام وانت بخير(1).xlsm

بالمعادلات

[محمد هشام.]

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

Sub Sheets_Arr()

Dim a, b, C As Variant, lr&
Dim Dest As Worksheet: Set Dest = Sheets("eman")

'Columns : E,F,H,L,M,P,Q
  Const r As String = "5 6 8 10 12 13 16 17 "

   
 For Each C In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
   lastrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Row + 1

Application.ScreenUpdating = False
  lr = C.Columns("A:Q").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = Evaluate("row(10:" & lr + 10 & ")")
  b = Split(r)
  Dest.Range("c" & lastrow).Resize(lr, UBound(b)).Value = Application.Index(C.Cells, a, b)

Application.ScreenUpdating = True
  
  Next C

End Sub

 

عيد مبارك سعيد.xlsm

[أبوأحـمـد]

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

أتمنى أن يفيد هذا 

Sub TR7el()

Dim ro, ro4 As Long
    ro = Worksheets(1).Range("C" & Rows.Count).End(xlUp).Row
 Worksheets(1).Range("D10:E" & ro & ",J10:J" & ro & ",I10:I" & ro & ",K10:L" & ro & ",O10:P" & ro).Copy _
 Worksheets(4).Range("c10")
 
 ro = Worksheets(2).Range("C" & Rows.Count).End(xlUp).Row
  ro4 = Worksheets(4).Range("C" & Rows.Count).End(xlUp).Row + 1
 Worksheets(2).Range("D10:E" & ro & ",J10:J" & ro & ",I10:I" & ro & ",K10:L" & ro & ",O10:P" & ro).Copy _
 Worksheets(4).Range("c" & ro4)
 
  ro4 = Worksheets(4).Range("C" & Rows.Count).End(xlUp).Row + 1
  ro = Worksheets(3).Range("C" & Rows.Count).End(xlUp).Row
 Worksheets(3).Range("D10:E" & ro & ",J10:J" & ro & ",I10:I" & ro & ",K10:L" & ro & ",O10:P" & ro).Copy _
Worksheets(4).Range("c" & ro4)

   
End Sub

 

كل عام وانت بخير.xlsm

[محمد هشام.]

حل اخر في حالة الرغبة بمسح البيانات القديمة وترحيل الجديدة 

Sub Sheets_Arrays2() ' بالتنسيقات
Dim LR&, LR2&, lrow&
Dim wsData  As Variant
Dim Dest    As Worksheet: Set Dest = Sheets("eman")
lRow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row

Application.ScreenUpdating = False
Dest.Range("C10:J" & lRow).ClearContents

For Each wsData In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
a = wsData.Cells(Rows.Count, "E").End(xlUp).Row
b = Dest.Cells(Rows.Count, "C").End(xlUp).Row

   wsData.Range("E10:F" & a).Copy Dest.Range("C" & b + 1)
   wsData.Range("H10:H" & a).Copy Dest.Range("E" & b + 1)
   wsData.Range("J10:J" & a).Copy Dest.Range("F" & b + 1)
   wsData.Range("L10:M" & a).Copy Dest.Range("G" & b + 1)
   wsData.Range("P10:Q" & a).Copy Dest.Range("I" & b + 1)
 
 Application.ScreenUpdating = True

  Next wsData

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' قيم

Sub Sheets_Arrays3()
Dim LR&, LR2&
Dim wsData        As Variant
Dim Dest    As Worksheet: Set Dest = Sheets("eman")

lrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row
Application.ScreenUpdating = False
Dest.Range("C10:J" & lrow).ClearContents

For Each wsData In Sheets(Array("sheet1", "sheet2", "sheet3"))
LR = wsData.Cells(Rows.Count, "E").End(xlUp).Row
LR2 = Dest.Cells(Rows.Count, "C").End(xlUp).Row + 1
 
    With wsData
 
        Dest.Range("C" & LR2 & ":d" & LR2 + LR - 10).Value = wsData.Range("E10:F" & LR).Value
        Dest.Range("E" & LR2 & ":e" & LR2 + LR - 10).Value = wsData.Range("H10:H" & LR).Value
        Dest.Range("F" & LR2 & ":F" & LR2 + LR - 10).Value = wsData.Range("J10:J" & LR).Value
        Dest.Range("G" & LR2 & ":h" & LR2 + LR - 10).Value = wsData.Range("L10:M" & LR).Value
        Dest.Range("I" & LR2 & ":j" & LR2 + LR - 10).Value = wsData.Range("P10:Q" & LR).Value
 
    End With
 

  Application.ScreenUpdating = True

  Next wsData

End Sub

 

 

 

 

عيد مبارك سعيد2.xlsm

تم تعديل يونيو 28, 2023 بواسطه Mohamed Hicham

[2saad]

شكرا لكم جميعا وجعله الله في ميزان حسناتكم جميعا وعيد سعيد علينا وعليكم وكل عام وانتم بخير وسعادة وزادكم الله من علمه