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
