مطلوب ترحيل بيانات غير مرتبة

أرجو التكرم بمساعدتى فى ترحيل البيانات

لدى كم كبير من البيانات الغير مرتبة فى شيت واحد و أريد عمل جدول واحد يحتوى على كل هذه البيانات

مرفق ملف به مثال لما أريد
حمل الملف
و شكرا مسبقا لمساعدتى

جرب هل هذا المطلوب

[url= https://mega.nz/#!ojJyGQRC!xV-DIY-SBms3wTtC1ktnZrM91Fho37Y0ejmtctIweNM]حمل الملف[/url]

طلبك صعب تحقيقة بمعادلة يااخى العزيز ولو تمت بمعادلة صفيف على قدر كل تلك البيانات لاثقلت الملف جدا
ولكن يمكن تنفيذها بالكود في اقل من ثانية
جرب الكود التالى وانتظر ردك
اعمل زر وضع الكود بداخلة

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

او حمل الملف
الملف

شكرا استاذى الفاضل

اى خدمة