I have a worksheet with a few hundred data groups and I like to consolidate the

data to another worksheet. Each data group starts with a title row looks like:

*TITLE (DATA GROUP NUMBER ONE)

Each group has 10-20 data lines. Each line represents a material layer and has 4

data in column A, B, C, and D, except the first line that has 5 data. The data

in column A is thickness of the layer and B, C, D are the material

specifications. The fifth data of first data line is the total thickness of the

layers in the group. There are 1-4 blank lines between the data groups. The data

looks like these:

Col A Col B Col C Col D Col F

45.02 3 P_1 33 228.26 <= first data line

27.32 3 P_1 33 col F = Sum of Col A

15.02 4 P_1 45 of the data group

6.47 4 P_1 45

7.47 3 P_1 33

28.34 3 P_1 21

98.62 3 P_2 45

I like to using VBA to rewrite the data into another worksheet. The title row

will be copied and blank lines between data groups will be removed. If the

adjacent layers have same specifications (Column B,C,D), the thickness will be

added up and become a single layer. Therefore, the number of data rows will be

reduced, but the order of the layers and total thickness of layers will remain

the same.

*TITLE (DATA GROUP NUMBER ONE)

72.34 3 P_1 33 228.26

21.49 4 P_1 45

7.47 3 P_1 33

28.34 3 P_1 21

98.62 3 P_2 45

*TITLE (DATA GROUP NUMBER TWO)

35.61 3 P_1 33 196.26

...

Can any body help?

Thanks in advance.

Best Regards.

TKC

following macro should do the job for you.

In the beginning of the macro, the variables Source and Dest are assigned to "sheet1" and "sheet2", you'll have to enter the worksheet names of your choice in there.

Sub TransformSheet()

Dim Source As Worksheet, Dest As Worksheet

Dim i As Integer, NuLi As Integer, EndBlock As Integer

Dim j As Integer, k As Integer, Thick As Double

Set Source = Sheets("sheet1")

Set Dest = Sheets("sheet2")

NuLi = Source.Cells(1, 1).SpecialCells(xlCellType

j = 1

i = 1

While i <= NuLi

If Source.Cells(i, 1) <> "" Then

EndBlock = Source.Cells(i, 1).End(xlDown).Row

Dest.Cells(j, 1) = Source.Cells(i, 1)

j = j + 1

Start = j

With Source

For k = i + 1 To EndBlock

If .Cells(k, 2) = .Cells(k + 1, 2) And .Cells(k, 3) = .Cells(k + 1, 3) And .Cells(k, 4) = .Cells(k + 1, 4) Then

Thick = .Cells(k, 1) + Thick

Else

Thick = .Cells(k, 1) + Thick

Dest.Cells(j, 1) = Thick

Dest.Cells(j, 2) = .Cells(k, 2)

Dest.Cells(j, 3) = .Cells(k, 3)

Dest.Cells(j, 4) = .Cells(k, 4)

Thick = 0

j = j + 1

End If

Next k

Dest.Cells(Start, 6).Formula = "=Sum($A$" & Start & ":$A$" & j - 1 & ")"

End With

i = EndBlock + 1

Else

i = i + 1

End If

Wend

End Sub

Have Fun

Calacuccia

PS If you need more explanation, just shout