الجدول معمول بالوورد وليس إكسل
حولته لك على الوورد
بكل سهولة تستطيع النسخ من الوورد إلى الإكسل لو تحب
لكن .. لاحظ بعض الخلايا النص طويل جدا أنسب تكون في الوورد
تحياتي
BOQ.docx
حدد صف العناوين وصف (أو صفوف) تحته
ثم من قائمة إدراج بالأعلى اختر (جدول) الثالثة من اليمين تقريبا
وتستطيع الوصول له من خلال لوحة المفاتيح بالضغط على CTRL+L
تحياتي
تم الحل بعد محاولات وتجارب لكن حصل المقصود
لكم الشكر يا سادة
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
