How to differentiate between noncontiguous ranges?

I am trying to perform a few operations on a dynamic number of ranges that are also dynamically sized. Each time the program is run, the number of noncontiguous ranges may change, as well as the size of the ranges. I identify my ranges by finding the delimiter in Column A, which is the underscore. Right now, VBA is recognizing the ranges seen below as two different areas, but selects them both at the same time when called to find the strings containing the delimiter, which is correct. I am transposing my range areas from one page to the next. In the first column of each range, Column A, there is a name, and the rest of the row contains various numbers. In each range, the string names vary, but they all correspond to the string names in the other range(s). For instance, all the first string names in each range end with _1. The second string name in the range (or the cell in the row beneath the first string), ends in _2, for each range. Below is a picture:

I know I can remove the blank row in between each range, but I don't think it is the best solution for my desired output. I would like to take the first row of the first area (in this example, A5:E5), transpose it, and paste it on a new sheet from (in this example) B5:B9. I would then like to go to the next area and do the same thing (so, copy A9:E9), transpose it, and paste it on the same sheet in the next column (so, C5:C9). Then I'd like to go back to my first range, and take the next row (A6:E6), tranpose it, and paste to D5:D9, then go to the next area and take (A10:E10), and so on until all the ranges have been pasted to the new page. So, ideally, I'd like to alternate between ranges and paste each row into a column, continuously through each range. This is my desired output:

I am having a hard time getting the data the way I want it, and know that I may not have the option to alternate between ranges, so I am up to hearing any ideas. Again, the number of ranges (or areas) can change with each run, and so can the size of the ranges. For this example, I had two ranges with 3 string names, but next run, I could have three ranges with 4 string names, so I can't hard code anything. The string names will not always be the same (input_x, output_x) so I can't hard code these either, but I can search for the delimiter, the underscore in the string name, as it will always be formatted into the string name.

My current output DOES copy and paste by each cell in the area, but this is the best I have gotten with what I have tried:

Here is my code (comments are some things I have been trying):

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

Any help or pointers in the right direction would be much appreciated. Thank you!
Sorry for the length of this question.

Here is an alternative example that works using memory-based arrays for speed as well as helping with the transposition and correct sizing of the data.

This algorithm assumes:

1. You'll always have data sets that start with _1
2. The data set numbers always increase sequentially, e.g. _1, _2, _3 etc
3. There will always be an equal number of data "groups" as there are data sets.

My sample data looks like this:

First, I move the data into a memory-based array

Dim inData As Variant
inData = Sheet1.UsedRange.Value

Then based on these assumptions, in order to properly sort the results you need to figure out how many data sets you have. So I created this function that takes advantage of the Split function to get the number value following the underscore:

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

So the main routine calls

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

By calculating allSetsCount in this way, you're effectively skipping any blank rows in your input data.

Now create an array to hold all the transposed data

'--- 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)

And finally run through your data to collect the data sets in order and transpose the data to the output array.

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

Here's the whole module for all the code

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

Please try this code. It works only in memory and is very fast. I will try to explain for some lines, which may be looking strange, what they do. It works no matter of any ("_") character of the strings in A:A column.
This is the starting sheet ("Areas"):

And this is the result ("Final") sheet:

Sub testTransposeMyAreas()
Dim sh As Worksheet, rngUR As Range, j As Long, ii As Long
Dim rng As Range, usedR As Range, rA As Range, arVal As Variant
Dim shFin As Worksheet, k As Long, i As Long, ArTr() As Variant

  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

If something unclear, do not hesitate to ask for clarifications.

This code start from the assumption that all rows and columns number in an area are equal.

In order to better see how it works, I would suggest to un-comment the Stop command after ...Transpose(ArTr), make VBE window smaller and see what is happening on the worksheet, pressing F5 after each stop.