Dim myRange as Range
Dim c as Range, a as Range
Dim t As Long, m as Long
Dim delimiterItem as Variant
Dim newSheetName as String
newSheetName = ActiveSheet.Name
delimiterItem = "_"
t = 2
	With Sheets.Add(After:=Sheets(Sheets.Count))
        .Name = "Final"
        
        
        If myRange Is Nothing Then
            MsgBox ("Value not present in this workbook.")
        Else
            For Each a In myRange.Areas
                            
                For Each c In a.Rows
                    Worksheets(newSheetName).Activate
                    c.EntireRow.Copy
                    'For m = Cells(myRange.Rows.Count, 1).End(xlUp).Row To 2 Step -1
                    'If Split(InStrRev(myRange.Cells(m, 1).Text, delimiterItem))(0) = Split(InStrRev(myRange.Cells(m - 1, 1).Text, delimiterItem))(0) Then
                                  
                    Worksheets("Final").Activate
                    Cells(8, t).Select
                    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                          False, Transpose:=True
                                    
                    t = t + 1
                    'Sheets("Final").Range("B8").Offset(0, (t - 2) * 2).PasteSpecial xlPasteValues
                Next c
             Next a
        End If
    End With

Dim inData As Variant
inData = Sheet1.UsedRange.Value

Private Function DetermineNumberOfSets(ByRef data As Variant) As Long
'--- runs through the labels in the first column and separates
'    the number value following the underscore to find the maximum
'    count of data sets
Dim max As Long
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
Dim tokens As Variant
tokens = Split(data(i, 1), "_")
If UBound(tokens) > 0 Then
If max < tokens(1) Then max = tokens(1)
End If
Next i
DetermineNumberOfSets = max
End Function

Dim dataSetCount As Long
Dim columnCount As Long
dataSetCount = DetermineNumberOfSets(inData)
'--- this determines how many columns are in the output data
Dim allSetsCount As Long
allSetsCount = dataSetCount * dataSetCount

'--- this determines how many rows are in the output data
Dim maxDataPointsCount As Long
maxDataPointsCount = UBound(inData, 2)
Dim outData As Variant
ReDim outData(1 To maxDataPointsCount, 1 To allSetsCount)

Dim setNumber As Long
For setNumber = 1 To dataSetCount
'--- run through the data and pick out the data for this set
Dim i As Long
For i = LBound(inData, 1) To UBound(inData, 1)
Dim thisSetNumber As Long
thisSetNumber = WhatsTheDataSet(inData(i, 1))
If thisSetNumber = setNumber Then
'--- copy this set to the output
Dim j As Long
For j = 1 To maxDataPointsCount
outData(j, outputColumn) = inData(i, j)
Next j
outputColumn = outputColumn + 1
End If
Next i
Next setNumber

Option Explicit
Option Base 0
Public Sub CollateData()
Dim inData As Variant
inData = Sheet1.UsedRange.Value
Dim dataSetCount As Long
Dim columnCount As Long
dataSetCount = DetermineNumberOfSets(inData)
'--- this determines how many columns are in the output data
Dim allSetsCount As Long
allSetsCount = dataSetCount * dataSetCount
'--- this determines how many rows are in the output data
Dim maxDataPointsCount As Long
maxDataPointsCount = UBound(inData, 2)
Dim outData As Variant
ReDim outData(1 To maxDataPointsCount, 1 To allSetsCount)
Dim outputColumn As Long
outputColumn = 1
Dim setNumber As Long
For setNumber = 1 To dataSetCount
'--- run through the data and pick out the data for this set
Dim i As Long
For i = LBound(inData, 1) To UBound(inData, 1)
Dim thisSetNumber As Long
thisSetNumber = WhatsTheDataSet(inData(i, 1))
If thisSetNumber = setNumber Then
'--- copy this set to the output
Dim j As Long
For j = 1 To maxDataPointsCount
outData(j, outputColumn) = inData(i, j)
Next j
outputColumn = outputColumn + 1
End If
Next i
Next setNumber
Dim outRange As Range
Set outRange = Sheet2.Range("A1").Resize(UBound(outData, 1), UBound(outData, 2))
outRange.Value = outData
End Sub
Private Function DetermineNumberOfSets(ByRef data As Variant) As Long
'--- runs through the labels in the first column and separates
'    the number value following the underscore to find the maximum
'    count of data sets
Dim max As Long
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
Dim tokens As Variant
tokens = Split(data(i, 1), "_")
If UBound(tokens) > 0 Then
If max < tokens(1) Then max = tokens(1)
End If
Next i
DetermineNumberOfSets = max
End Function
Private Function WhatsTheDataSet(ByVal label As String) As Long
Dim tokens As Variant
tokens = Split(label, "_")
If UBound(tokens) > 0 Then
WhatsTheDataSet = tokens(1)
End If
End Function

  Set sh = ActiveWorkbook.Worksheets("Areas") ' obviously the sheet keeping areas to be transposed
If Sheets(Sheets.count).Name = "Final" Then
Set shFin = ActiveWorkbook.Worksheets("Final")
shFin.UsedRange.Clear' for testing reason only
Else
Set shFin = Sheets.Add(After:=Sheets(Sheets.count))
shFin.Name = "Final"
End If
Set rngUR = sh.UsedRange
'define all the (really used range) of the worksheet:
Set usedR = sh.Range(rngUR.Cells(1, 1).Address & ":" & _
rngUR.Cells(rngUR.Rows.count, rngUR.Columns.count).Address)
'tricky way to separtate the areas...
Set rng = usedR.SpecialCells(xlCellTypeConstants)
k = 0      
For Each rA In rng.Areas
ReDim ArTr(rA.Columns.count) 'redim the array used to transfer data to the "Final" one
arVal = rA.Value 'load the area range in ArVal array
For i = 1 To rA.Rows.count
For ii = 0 To rA.Columns.count - 1
ArTr(ii) = arVal(i, ii + 1) 'fill the transfer array (diferently for each area row)
Next ii
'create the paste range and make the transfer:
'to optimize the code, it does what you explain, but not in that suggested order
'I mean, it firstly fill column B:B, then the column situated at how manu areas exists (once for each iteration)
shFin.Range(Cells(5, 2 + k + j).Address & ":" & Cells(rA.Columns.count + 4, 2 + k + j).Address).Value = _
Application.WorksheetFunction.Transpose(ArTr) ': Stop
k = i * rng.Areas.count ' used to define position of the next column to be filled
Next i
j = j + 1: k = 0
Next
End Sub