Extracting Output in Other Format Type 1

If your have data in the given structure and you want it to restructure your data into a given format then you can use this code to restructure and format your new data block.

Input data Structure:

Output Data Structure:

Code :

Option Explicit

Sub split()
    
    Dim i, j, k, splitRow, splitCol, blockCount, columnCount, segmentCol As Long
    Dim dataBlock(500) As String
    Dim dataBlockCol(500) As Integer
    
    Dim summaryRow, countGFS As Integer
    summaryRow = ((Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row - 2) * 2) + 1
    
    splitRow = 2
    splitCol = 1
    segmentCol = 1
    blockCount = 0
    Sheet2.Cells.Clear
    
    'finding data names and location of individual data blocks
    For i = 2 To Sheet1.UsedRange.Columns.Count
        If Sheet1.Cells(1, i).Value <> "" Then
            blockCount = blockCount + 1
            dataBlock(blockCount) = CStr(Sheet1.Cells(1, i).Value)
            dataBlockCol(blockCount) = i
        End If
    Next i
    
    countGFS = 2
    'spliting cell contents
    For j = 1 To blockCount
        Sheet2.Cells(1, splitCol).Value = dataBlock(j)
        
        Sheet2.Cells(summaryRow - 1, splitCol).Value = "-"
        Sheet2.Cells(summaryRow, splitCol).Value = dataBlock(j)
        Sheet2.Cells(summaryRow + 1, splitCol).Value = "ASDF"
        
        columnCount = 0
        For i = 3 To Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row - 1

            Sheet2.Cells(1, splitCol + 1).Value = "Col" & CStr(columnCount)

            Sheet2.Cells(splitRow, segmentCol).Value = Sheet1.Range("A" & CStr(i)).Value
            Sheet2.Cells(splitRow, splitCol + 1).Value = Sheet1.Cells(i, dataBlockCol(j) + 4).Value
            Sheet2.Cells(splitRow + 1, segmentCol).Value = Sheet1.Range("A" & CStr(i)).Value
            Sheet2.Cells(splitRow + 1, splitCol + 1).Value = Sheet1.Cells(i, dataBlockCol(j) + 5).Value
            
            Sheet2.Cells(summaryRow - 1, splitCol + 1).Value = "-"
            Sheet2.Cells(summaryRow, splitCol + 1).Value = Sheet1.Cells(2, countGFS).Value
            Sheet2.Cells(summaryRow + 1, splitCol + 1).Value = Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row, countGFS).Value
            
            splitRow = splitRow + 2
            splitCol = splitCol + 1
            columnCount = columnCount + 1
            countGFS = countGFS + 1
            
            If i = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row - 1 Then
                Sheet2.Cells(summaryRow, splitCol + 1).Value = Sheet1.Cells(2, countGFS).Value
                Sheet2.Cells(summaryRow + 1, splitCol + 1).Value = Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row, countGFS).Value
            End If
            
            
        Next i
        
        countGFS = countGFS + 1
        splitRow = 2
        splitCol = Sheet2.UsedRange.Columns.Count + 4
        segmentCol = splitCol

    Next j
    
    'copying formatting
    Sheet2.Select
    For j = 1 To blockCount
        If j = 1 Then
            Range("A1").Select
        Else
            Cells.Find(What:=dataBlock(j), After:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
            , SearchFormat:=False).Activate
        End If
        
        
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Sheet1.Select
        Cells.Find(What:=dataBlock(j), After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        ActiveCell.Offset(1, 0).Select
        Selection.Copy
        Sheet2.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        
        Selection.End(xlDown).Select
        Selection.Copy
        Selection.End(xlToRight).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        ActiveCell.Offset(-1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Range("A1").Select
        Application.CutCopyMode = False
    Next j
    
    Rows(summaryRow - 1).Clear
    Cells.Select
    Selection.Columns.AutoFit
    Range("A1").Select
    
    Sheet1.Select
    Range("A1").Select
    
    Sheet2.Select
    MsgBox "Split complete"
    
End Sub

Explanation :

In the above mentioned code
Sheet1 is the Input Data Sheet
Sheet2 is the Output Data Sheet

Example File link :

Example File