[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now


Using VBA to consolidate a Excel worksheet

Posted on 2000-02-25
Medium Priority
Last Modified: 2011-04-14
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:


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.

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
35.61        3        P_1       33                             196.26

Can any body help?

Thanks in advance.

Best Regards.
Question by:tkc
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
LVL 17

Expert Comment

ID: 2560822
Hi 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(xlCellTypeLastCell).Row
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
    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
i = i + 1
End If
End Sub

Have Fun


PS If you need more explanation, just shout

Author Comment

ID: 2561182

Hello, Calacuccia, Thank you very much for your help.  
The macro works fine, except that a Run-time error '1004' (Unable to get the specialCells property of the Range Class) was shown relate to the line:
I commented out the line, then set NuLi=500. The macro works. I use Excel 97 SR2, is it any problem for this version?  BTW, could you please show me how to copy the row of the title line (not only the column A)?

Thanks again. I really appreciate it.

LVL 44

Expert Comment

ID: 2561196
hmmm...good answer and got no trouble running it here in Excel2000...
Fill in the form and get your FREE NFR key NOW!

Veeam® is happy to provide a FREE NFR server license to certified engineers, trainers, and bloggers.  It allows for the non‑production use of Veeam Agent for Microsoft Windows. This license is valid for five workstations and two servers.

LVL 17

Accepted Solution

calacuccia earned 800 total points
ID: 2562678

To copy the entire title line, change the line (just after the EndBlock line)
Dest.Cells(j, 1) = Source.Cells(i, 1)
Dest.Rows(j).Value = Source.Rows(i).Value

I don't know why the xlCellTypeLastCell gives a run-time error, just as Bruintje shows (thanks for support, Bruintje), I've had no problem in Excel 97 SR1.

It would surprise me that SR2 gets this property buggy. If you can live with setting NuLi to 500 than your problem is by-passed.

Found following article about run-time errors using the specialCells properties:
This one occurs when you have the sheet protected, workaround: unprotect your sheet.
Maybe that applies to you ?



Author Comment

ID: 2562790
Hi, Calacuccia,
         Thank you for the help. The macro works great now. I can live by manually setting NuLi. I really appreciate your fast responce and enjoy the program.
         Thanks again.
Best regard,
LVL 17

Expert Comment

ID: 2562800
Thanks TKC

Glad you liked the program


Featured Post

[Webinar] Lessons on Recovering from Petya

Skyport is working hard to help customers recover from recent attacks, like the Petya worm. This work has brought to light some important lessons. New malware attacks like this can take down your entire environment. Learn from others mistakes on how to prevent Petya like worms.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

New style of hardware planning for Microsoft Exchange server.
Microsoft has changed the look and feel of Azure AD and Microsoft account sign-in pages so that you will have a more unified look and feel when moving between the two interfaces.
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…

650 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question