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