مداد_1423

الجدول معمول بالوورد وليس إكسل
حولته لك على الوورد
بكل سهولة تستطيع النسخ من الوورد إلى الإكسل لو تحب
لكن .. لاحظ بعض الخلايا النص طويل جدا أنسب تكون في الوورد
تحياتي
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  

في خلية B1 جرب تغير نص الخلية من 
Government Exp
إلى
Government_Exp
بحيث تستبدل المسافة بالشرطة السفلية
وبتزبط معك

 
المشكلة عندك في تسمية صف العناوين (المسافات)
تحياتي