Я знаю, что это осуждается, но проблема звучит интересно, поэтому я просто написал VBA
Попробуйте код ниже. Я установил константы для работы с примером, который вы привели, но вы можете изменить их для своего реального приложения.
Function CompressReport()
'Settings for which columns are the header and details
Const fHC As Long = 1 'First header column number
Const lHC As Long = 6 'Last header column number
Const fDC As Long = 7 'First detail column number
Const lDC As Long = 11 'Last detail column number
'Declarations
Dim rStart&, rStop&, rNew As Long
Dim r&, c As Long
Dim ws As Worksheet
Dim wsNew As Worksheet
Dim s1$, s2 As String
'Set the source worksheet to be compressed
'(Here are a few methods to do this. Pick one.)
Set ws = Sheet1
Set ws = Worksheets(1)
Set ws = Worksheets("Sheet1")
'Add a new worksheet for our results
Set wsNew = Worksheets.Add(After:=ws)
With ws
'Copy the first row of headers
.Range(.Cells(1, fHC), .Cells(1, lHC)).Copy wsNew.Cells(1, 1)
rNew = 2
'Loop through all the rows
For rStart = 2 To ws.UsedRange.Rows.Count
'Copy the header information
.Range(.Cells(rStart, fHC), .Cells(rStart, lHC)).Copy wsNew.Cells(rNew, 1)
'Add a thick border (This wasn't in the OP but I recommend it)
With wsNew.Range(wsNew.Cells(rNew, 1), wsNew.Cells(rNew, lHC - fHC + 1)).Borders(xlEdgeTop)
.LineStyle = xlContinuous 'You could also try xlDouble
.Weight = xlThick
End With
'Collect the header information into a single unique ID
s1 = ""
For c = fHC To lHC
s1 = s1 & "|" & .Cells(rStart, c).Value
Next
'Find the next row with different information
For rStop = rStart + 1 To .UsedRange.Rows.Count
s2 = ""
For c = fHC To lHC
s2 = s2 & "|" & .Cells(rStop, c).Value
Next
If s2 <> s1 Then Exit For
Next
rStop = rStop - 1
'Copy the detail headers and information
.Range(.Cells(1, fDC), .Cells(1, lDC)).Copy wsNew.Cells(rNew + 1, 2)
.Range(.Cells(rStart, fDC), .Cells(rStop, lDC)).Copy wsNew.Cells(rNew + 2, 2)
'Increase the row we're pasting in the new worksheet
' +1 for header data, +1 for detail headers, +n for detail information
rNew = rNew + 1 + 1 + (rStop - rStart + 1)
'Increase the row we're copying in the source worksheet
rStart = rStop 'The FOR loop will iterate it +1
Next
End With
'Formatting (feel free to add to this part)
With wsNew
.Columns.AutoFit
End With
'Cleanup
Set wsNew = Nothing
Set ws = Nothing
End Function
