Microsoft Excel Power

Lesson 4: Project 2

The Code

Dim rng As Range
Dim xrng As Range
Dim lLastRow As Integer
Dim lLastCol As Integer
Dim prjlLastRow As Integer
Dim prjlLastCol As Integer
Dim actlLastRow As Integer
Dim actlLastCol As Integer
Dim totlLastRow As Integer
Dim totlLastCol As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim CurPos As Integer
Dim DelCnt As Integer
Dim DirectoryPath As String
Dim r As Integer
Dim searchstring As String
Dim loeTotal  As Double
Dim actTotal As Double
Dim remFcst As Double
Dim CurSR As String
Dim CurAplID As String
Dim firstRow As Boolean
Dim firstAplid As Boolean
Dim wdApp As Word.Application

A bigger list of variables this time but most of them should be familiar, except for the last one, we will come back to that one later. Now, you could, if you wished, place your variables throughout the code, but then it will make the code difficult to manage, so it is always best to define them at the beginning of your macro.

Application.StatusBar = "Processing Data FIle"

Display what I'm doing for the benefit of whoever is running the macro, even if it is only me.

Set rng = Worksheets("Bdgt").Range("A1").SpecialCells(xlCellTypeLastCell)
lLastRow = rng.Row
lLastCol = rng.Column

Usual code to get the dimensions of the data; notice the Worksheets("Bdgt"). To make sure that we have the correct sheet.

Worksheets("Bdgt").Select

I specifically select the Bdgt sheet (I know that I was probably already there, but I may not be running the macro) just to make sure, as the next bits of code are kind of critical.

' Strip out total lines, blank lines
'
For i = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If ((Cells(i, "B").Value Like "*Total*") Or IsEmpty(Cells(i, "B").Value)) Then
Cells(i, "B").EntireRow.Delete
DelCnt = DelCnt + 1
End If
Next i
lLastRow = lLastRow - DelCnt

This first bit will go through the rows and delete any blank lines, and lines that are a Total line. Again, we work from the bottom up.

The test for blank lines is pretty standard:

IsEmpty(Cells(i, "B").Value)

I'm using the Cells option, with the row specified by i, which is varied by the loop. I know that the value "Total" is always in column "B", hence that is so specified, it makes sense to use the same column for both tests. I use the Excel function IsEmpty to see if the line is blank. If I wanted a non blank line, then I could use "Not IsEmpty".

To get rid of the Total lines I use:

(Cells(i, "B").Value Like "*Total*")

Here it is very important to use the Like phrase as the cell containing the word Total has other text in it and so a test of = "Total" would not work.

Cells(i, "B").EntireRow.Delete

This line gets rid of the unwanted row. We increment the DelCnt variable to later correct the row count.

Now for the unwanted columns.

' Delete unwanted columns
Columns("M:N").Select
Selection.Delete Shift:=xlToLeft
Columns("G:I").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

Delete the columns right to left or you will either have to figure the new column designations after each column is deleted or you won't have the correct columns when done.

Now here is a question for you. Could I have deleted the columns first and then deleted the rows? It would seem that the end result would be the same. However, it would not be. I have to delete the rows first, as one of the columns critical to the search in the row delete, column "B", is one that I intend to delete. So, if I had done it the other way round, I would not delete any Total lines.

Wow, you're thinking, "That was pretty smart!" - actually no, I did it the wrong way around the first time I ran the macro, and was puzzled for a few seconds as to why I had Yellow lines in the resulting data, of course the cell containing the word Total had been deleted when the column was deleted and so it was not immediately obvious. Hence, it is always good to have a backup of the data when you are testing macros.

Range("A1").Select

After the deletions are complete I select the first cell in the sheet as a final action. It is not necessary, but often your actions will mean that you end up in some odd part of the worksheet and so this just ensures that it looks normal for whoever is running the macro.

Worksheets("Bdgt").Activate
Sheets.Add after:=Sheets("Bdgt")
Sheets(Sheets.Count).Name = "Actuals"
Application.StatusBar = "Extracting Project Details"

To add a new sheet I first ensure that the Bdgt one is active, then I use the

Sheets.Add after:=Sheets("Bdgt")

The default when adding a sheet is to put it to the left, or before the active sheet, so I specify the after:= option. If I had more than the two sheets in the worksheet I could specify that the new one be added after any of them. Strictly speaking, as long as I qualify the sheet with the Worksheets(sheet name), it doesn't matter what order they are in, I do it just to make logical sense. To give the sheet a more meaningful name I use the following

Sheets(Sheets.Count).Name = "Actuals"

This uses the Sheets property Name, to change the name of it. Notice that I reference the new sheet with Sheets.Count. This is a special variable updated by Excel when you add or delete sheets. Hence, Sheets.Count would be equal to 3 when we added the new one, and the new one would then obviously be number 3. This is why I placed the Bdgt backup data in a separate spreadsheet; otherwise it would have messed up the numbering. I could have worked around this problem, but this solution made more sense.

Application.StatusBar = "Extracting Project Details"
Set rng = Worksheets("projects").Range("A1").SpecialCells(xlCellTypeLastCell)
prjlLastRow = rng.Row
prjlLastCol = rng.Column
CurPos = 5
k = 1

Use the StausBar to describe what you are doing. Usual get the dimensions of the data code, specific to the projects sheet. I'm also setting a couple of variables here - CurPos is going to be used to keep track of where I am in the {Bdgt} Data, and k will keep track of where I am in the actuals sheet.

For i = 1 To prjlLastRow Step 1
For j = CurPos To lLastRow Step 1
If Left(Worksheets("Projects").Cells(i, "A").Value, 5) =
Left(Worksheets("Bdgt").Cells(j, "A").Value, 5) Then
Sheets("Bdgt").Activate
Set xrng = Worksheets("Bdgt").Range(Cells(j, "A"), Cells(j, "G"))
xrng.Select
Selection.Copy
Sheets("Actuals").Select
Worksheets("Actuals").Range(Cells(k, "A"), Cells(k, "G")).Select
ActiveSheet.Paste
CurPos = j
k = k + 1
End If
Next j
Next i

There is a lot going on here, but it is pretty straightforward. I need two loops, one to work through the list of projects and the other to find a corresponding match on project in the {Bdgt} data. I start off with the first project value in the {projects} sheet with

For i = 1 To prjlLastRow Step 1

The loop variable i, is used to control this loop and has as its initial value 1, and the last value will be prjlLastRow, the last data row in this sheet.

For j = CurPos To lLastRow Step 1

In the loop that searches the actuals data in the Bdgt sheet, I use the variable j, and set it initially to 5, the first row of data after the headings. Its last value will be lLastRow. I probably should have called this value bdglLastRow!

If Left(Worksheets("Projects").Cells(i, "A").Value, 5) =
Left(Worksheets("Bdgt").Cells(j, "A").Value, 5) Then

This statement is the important one; it is comparing the value of the project value in the projects sheet Column "A" with the corresponding value in the Bdgt sheet, also in column "A". Now the actual value of the project in the projects sheet is given by

Worksheets("Projects").Cells(i, "A").Value

But, some of the project codes have additional characters added on to them, usually a period followed by a letter. This is a complication I don't want to have to deal with, and so I use an Excel function to get the first 5 characters of the value. Thus

Left(value, 5)

Will extract the first 5 characters from the left of whatever is in value; there is a similar function to get characters from the Right.

If I find a match, I then copy the data.

Sheets("Bdgt").Activate

First, activate the sheet.

Set xrng = Worksheets("Bdgt").Range(Cells(j, "A"), Cells(j, "G"))

Then set the range of data to be copied. Note, we get the data in cells A - G for the corresponding row value i.

xrng.Select
Selection.Copy

Here I select the range of data and then place the selection into the copy buffer. Now I reverse the process and paste the data into the actuals sheet.

Sheets("Actuals").Select
Worksheets("Actuals").Range(Cells(k, "A"), Cells(k, "G")).Select
ActiveSheet.Paste

The first statement selects the Actuals sheet. We then select a range in this sheet. Notice we are using the variable k to determine which row is next. To then paste the data we use ActivePaste. Most of these statements were determined using the macro recorder. The result of these statement is to copy a matching project's data from the Bdgt sheet to the Actuals sheet. After the copy I update the appropriate variables.

CurPos = j
k = k + 1

I update k by one so that the next row of data will be pasted correctly into this sheet. CurPos is also updated by one so that I don't have to start over from the first data row in the Bdgt's sheet. This works because the project values in both sheets (projects, Bdgt) are sorted in sequence, if they were not, I would have to search the entire set of data rows in Bdgt for every project in the projects sheet; for a large amount of data that could be very time consuming.

The loop is completed by the next i, and next j statements.

Now for the big loop.

Application.StatusBar = "Calculating Totals"
Worksheets("Bdgt").Activate
Sheets.Add after:=Sheets("Actuals")
Sheets(Sheets.Count).Name = "Totals"

Let everyone know what we are doing and then create a new sheet, called Totals, after the Actuals sheet.

Set rng = Worksheets("Actuals").Range("A1").SpecialCells(xlCellTypeLastCell)
actlLastRow = rng.Row
actlLastCol = rng.Column
CurSR = Worksheets("Actuals").Cells(2, "A").Value
CurAplID = Worksheets("Actuals").Cells(2, "C").Value
j = 1

First get the dimensions of the data in Actuals; then initialize the variables CurSR and CurAplID with the values from the first line of data in the Actuals sheet. We are going to sum the values within the SR and ApplID and so need to set a start value. Thus, when either of these values changes, we have our summed value for the previous combination. For example, the first SR in the data is XJ637 and the ApplID is 33P, so the totals from this combination that we want to write to the Totals sheet would be the following:

Column D - 9346
Column E - 10330
Column F - 76

If you add up the values for these corresponding records in the Actuals sheet you will get these totals. We repeat this process for each unique combination of SR/ApplID in Actuals.

The row control variable j, is set to 1, the first row to be populated in the Totals sheet.

This next bit is a monster, so we will break it down.

For i = 1 To actlLastRow Step 1
If Not Worksheets("Actuals").Cells(i, "A").Value = CurSR Then
Worksheets("Totals").Cells(j, "A").Value = CurSR
                Worksheets("Totals").Cells(j, "B").Value = "Total"
Worksheets("Totals").Cells(j, "C").Value = CurAplID
Worksheets("Totals").Cells(j, "D").Value = loeTotal
Worksheets("Totals").Cells(j, "E").Value = actTotal
Worksheets("Totals").Cells(j, "F").Value = remFcst
j = j + 1
CurSR = Worksheets("Actuals").Cells(i, "A").Value
CurAplID = Worksheets("Actuals").Cells(i, "C").Value
loeTotal = 0
actTotal = 0
remFcst = 0
loeTotal = loeTotal + Worksheets("Actuals").Cells(i, "D").Value
actTotal = actTotal + Worksheets("Actuals").Cells(i, "E").Value
remFcst = remFcst + Worksheets("Actuals").Cells(i, "F").Value

Our For loop will go from 1 to the last data row in the Actuals sheet, given by actlLastRow. The first test is to see if we are still in the same SR of the SR/ApplID combination initially set up.

If Not Worksheets("Actuals").Cells(i, "A").Value = CurSR Then

The first time through the loop this value will match, in later loops if it does not, then we will place the accumulated total into the appropriate row in the Totals sheet.

Worksheets("Totals").Cells(j, "D").Value = loeTotal

In this statement we are putting the loeTotal into column "D" in the Totals sheet. After we have placed the values into Totals we clear down the stored variable values and populate them with the new values from the next row in Actuals. This may seem a little difficult, but just look through the code and check the values in the data sheets and it will make sense.

ElseIf Not Worksheets("Actuals").Cells(i, "C").Value = CurAplID Then
Worksheets("Totals").Cells(j, "A").Value = CurSR
Worksheets("Totals").Cells(j, "B").Value = "Total"
Worksheets("Totals").Cells(j, "C").Value = CurAplID
Worksheets("Totals").Cells(j, "D").Value = loeTotal
Worksheets("Totals").Cells(j, "E").Value = actTotal
Worksheets("Totals").Cells(j, "F").Value = remFcst
j = j + 1
CurSR = Worksheets("Actuals").Cells(i, "A").Value
CurAplID = Worksheets("Actuals").Cells(i, "C").Value
loeTotal = 0
actTotal = 0
remFcst = 0
loeTotal = loeTotal + Worksheets("Actuals").Cells(i, "D").Value
actTotal = actTotal + Worksheets("Actuals").Cells(i, "E").Value
remFcst = remFcst + Worksheets("Actuals").Cells(i, "F").Value

Here we are checking for a change of ApplID while still in the same SR. For example, the SR XJ637 has three ApplID values 33P, 71P, and 63P. We need to place a total line for each of these in the Totals sheet.

If neither SR nor AplID has changed then we just add to the stored totals.

Else
loeTotal = loeTotal + Worksheets("Actuals").Cells(i, "D").Value
actTotal = actTotal + Worksheets("Actuals").Cells(i, "E").Value
remFcst = remFcst + Worksheets("Actuals").Cells(i, "F").Value
End If
Next i

The next i, repeats the loop process.

Worksheets("Totals").Cells(j, "A").Value = CurSR
Worksheets("Totals").Cells(j, "B").Value = "Total"
Worksheets("Totals").Cells(j, "C").Value = CurAplID
Worksheets("Totals").Cells(j, "D").Value = loeTotal
Worksheets("Totals").Cells(j, "E").Value = actTotal
Worksheets("Totals").Cells(j, "F").Value = remFcst

This last block of code makes sure that we don't leave any data behind. This is typical in this type of programming, you have to take care of the first data elements and the last; it is often referred to as boundary conditions. When this code runs we will end up with a Totals sheet that has a Total line for each SR/ApplID combination in the Actuals sheet.

This last bit of code relates to the need to create a Word document with the data from the Totals sheet placed into it as a table.

Application.StatusBar = "Creating Word Document"
   Set rng = Worksheets("Totals").Range("A1").SpecialCells(xlCellTypeLastCell)
totlLastRow = rng.Row
totlLastCol = rng.Column
Set xrng = Worksheets("Totals").Range(Cells(1, "A"), Cells(totlLastRow, totlLastCol))
xrng.Copy
Set wdApp = New Word.Application

Here we are getting the range of data from the Totals sheet using the Range object specifying the first row and column to the last. We then use the xrng.Copy statement to put the data into the copy buffer. The Set wdApp = New Word.Application statement creates an instance of a Word object for us to paste the data into. This is the variable I mentioned earlier.

With wdApp
'.Documents.Open Filename:="C:\My Documents\Table.doc"
.Documents.Add
With .Selection
.TypeParagraph
.Paste
End With
Application.StatusBar = "Saving Word Document C:\My Documents\Table.doc"
.ActiveDocument.SaveAs "C:\My Documents\Table.doc"
.Quit
End With
Set wdApp = Nothing
Application.StatusBar = False

These are Word macro statements, they are contained within a With wdApp block, just like the With statement in Excel. We then add a new document using .Documents.Add And then with the previously copied data we paste it into the document. We then save the document in "C:\My Documents\" as Table.doc. the last few statements just Quit Word and release the created object.

The commented statement allows you to use an existing document rather than creating a new one. To use this functionality, known as OLE (Object Linking and Embedding), you must ensure that the Word objects are known to Excel. They may already be depending on your implementation of Microsoft ® Office. If the variable in the macro relating to the Word object wdApp gives an error, then you will have to add these objects to Excel. It can vary depending on the version of Word and Excel that you have, but here is the general way to do it. Select Tools->Preferences from the menu.

Fig 4.01 - the References option.

Then check to ensure that the Microsoft Word object is selected.

Fig 4.02 - Check the Word Object Library.

Your version of the object library may be different depending on which version of Word you have installed.

Print this page

  1  2  3