طلبك صعب تحقيقة بمعادلة يااخى العزيز ولو تمت بمعادلة صفيف على قدر كل تلك البيانات لاثقلت الملف جدا
ولكن يمكن تنفيذها بالكود في اقل من ثانية
جرب الكود التالى وانتظر ردك
اعمل زر وضع الكود بداخلة
Sub abo_dahab()
Dim Sh As Worksheet
Dim lc As Long
Dim lr As Long
Dim k As Long
Dim c As Range
Dim arr
'----------------------------------
Set Sh = Sheet1
lc = Sh.Cells(2, Sh.Columns.Count).End(xlToLeft).Column
lr = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
Sh.Range("a31:i" & lr + 1).ClearContents
'----------------------------------
Application.ScreenUpdating = False
For Each c In Sh.Range(Sh.Cells(1, 1), Sh.Cells(1, lc))
If c.Value <> "" Then
k = c.Column
lr = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
arr = Sh.Range(Sh.Cells(3, k), Sh.Cells(22, k + 7)).Value
Sh.Range("a" & lr + 1).Value = c.Value
Sh.Cells(lr, 2)(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End If
Next c
Erase arr
End Sub
او حمل الملف
الملف
_________________
لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك