طلب تعديل تجميع بإضافة شيت ويكون التجميع بيانات بدون تنسيق

[مداد_1423]

 

تحية طيبة 

وبعد:-

أتمنى يكون الجميع بصحة وسلامة

 

لدي ملف في كود من إبداع أستاذنا سليم حاصبيا

المطلوب إضافة شيت جديد بحيث يكون ترتيب التجميع في شيت ALL

أولا: Shift Schedule

ثانيا: Overtime

ثالثا: Attendance

ويكون التجميع بيانات من غير تنسيق إذا أمكن

 

 

 

مع الشكر لكل من مر هنا وأخص بالشكر والدعاء من ساعدني 

تحياتي

Option Explicit

Sub copy_data()
Dim S As Worksheet: Set S = Sheets("ALL")
Dim O As Worksheet: Set O = Sheets("Overtime")
Dim A As Worksheet: Set A = Sheets("Attendance")
Dim Final_S: Final_S = S.Cells(Rows.Count, 1).End(3).Row
Dim Final_O: Final_O = O.Cells(Rows.Count, 1).End(3).Row
Dim Final_A: Final_A = A.Cells(Rows.Count, 1).End(3).Row
Dim Rs As Range: Set Rs = S.Range("A8:AG" & Final_S)
Dim RO As Range: Set RO = O.Range("A8:AG" & Final_O)
Dim RA As Range: Set RA = A.Range("A8:AG" & Final_A)
Dim i%, xO%, XA%, xx%
xO = RO.Rows.Count: XA = RA.Rows.Count
Rs.ClearContents
i = 1: xx = 8
Do Until i > xO
  S.Cells(xx, 1) = RO.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RO.Columns.Count - 2).Value = _
  RO.Cells(i, 3).Resize(, RO.Columns.Count - 2).Value
 i = i + 1: xx = xx + 2
Loop
i = 1: xx = 9
Do Until i > XA
  S.Cells(xx, 1) = RA.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RA.Columns.Count - 2).Value = _
  RA.Cells(i, 3).Resize(, RA.Columns.Count - 2).Value
 i = i + 1: xx = xx + 2
Loop

End Sub

HR_TEST1.xlsm

[مداد_1423]

تم الحل بعد محاولات وتجارب لكن حصل المقصود 

لكم الشكر يا سادة

Sub copy_data()
Dim S As Worksheet: Set S = Sheets("ALL")
Dim Q As Worksheet: Set Q = Sheets("Shift Schedule")
Dim O As Worksheet: Set O = Sheets("Overtime")
Dim A As Worksheet: Set A = Sheets("Attendance")
Dim Final_Q: Final_Q = Q.Cells(Rows.Count, 1).End(3).Row
Dim Final_S: Final_S = S.Cells(Rows.Count, 1).End(3).Row
Dim Final_O: Final_O = O.Cells(Rows.Count, 1).End(3).Row
Dim Final_A: Final_A = A.Cells(Rows.Count, 1).End(3).Row
Dim RQ As Range: Set RQ = Q.Range("A8:AG" & Final_Q)
Dim Rs As Range: Set Rs = S.Range("A8:AG" & Final_S)
Dim RO As Range: Set RO = O.Range("A8:AG" & Final_O)
Dim RA As Range: Set RA = A.Range("A8:AG" & Final_A)
Dim i%, XQ, xO%, XA%, xx%
XQ = RQ.Rows.Count: xO = RO.Rows.Count: XA = RA.Rows.Count
Rs.ClearContents
i = 1: xx = 8
Do Until i > XQ
  S.Cells(xx, 1) = RQ.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RQ.Columns.Count - 2).Value = _
  RQ.Cells(i, 3).Resize(, RQ.Columns.Count - 2).Value
 i = i + 1: xx = xx + 3
Loop
i = 1: xx = 9
Do Until i > xO
  S.Cells(xx, 1) = RO.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RO.Columns.Count - 2).Value = _
  RO.Cells(i, 3).Resize(, RO.Columns.Count - 2).Value
 i = i + 1: xx = xx + 3
Loop
i = 1: xx = 10
Do Until i > XA
  S.Cells(xx, 1) = RA.Cells(i, 1)
  S.Cells(xx, 3).Resize(, RA.Columns.Count - 2).Value = _
  RA.Cells(i, 3).Resize(, RA.Columns.Count - 2).Value
 i = i + 1: xx = xx + 3
Loop

End Sub