يفضل في طرح الموضوع أن يرفق بمثال لشكل النتائج المتوقعة .. عموماً قمت بقراءة الكود الموجود وفهمت بعضاً من المطلوب بشكل عام وقمت بعمل كود آخر بشكل مختلف .. عله يفي بالغرض إن شاء الله
Sub Test()
Dim wsData As Worksheet, ws As Worksheet, sh As Worksheet, c As Range, m As Long, n As Long, r As Long, x As Long, col As Long
Application.ScreenUpdating = False
Set wsData = data0: Set ws = Sheet3: Set sh = sheet10
sh.Range("B5:H" & Rows.Count).ClearContents
m = ws.Cells(Rows.Count, 10).End(xlUp).Row
If m < 5 Then Exit Sub
For r = 5 To m
If ws.Cells(r, 10).Value = sh.Range("D2") Then
n = sh.Cells(Rows.Count, 4).End(xlUp).Row + 2: x = 0
sh.Cells(n, 3).Value = ws.Cells(r, 5).Value
sh.Cells(n, 4).Value = "مستخلص رقم " & ws.Cells(r, 5).Value
sh.Cells(n + 1, 4).Resize(11).Value = wsData.Range("B5").Resize(11).Value
sh.Cells(n, 5).Value = ws.Cells(r, 15).Value
For Each c In sh.Range("D" & n + 1).Resize(11).Cells
x = x + 1
col = Choose(x, 17, 19, 21, 23, 25, 27, 29, 31, 32, 33, 34)
sh.Cells(c.Row, 6).Value = ws.Cells(r, col).Value
Next c
End If
Next r
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub