VBA codes to sort, add, delete, populate worksheets

[detangler]

Hi All! I really need a lot of help here. Months ago I received generous help from someone at this forum with VBA codes that would allow me to add, sort, delete worksheets based on a list of departments specified in a worksheet called "Index".

I have since added bits and pieces of codes that do just a little more. Here's what I currently have:

Sub MakeDeptSheets()

Dim SheetExists As Boolean
Dim LastDept As Integer, i As Integer, j As Integer
Dim NewDeptName As String, NewDeptLName As String, Msg As String, Title As String
Dim UReply As String, FName As String

UReply = MsgBox("Your workbook must be saved before you can proceed further. Save workbook now?", _
    vbOKCancel + vbQuestion, "Save Workbook Now?")

Select Case UReply
Case vbCancel
MsgBox "You will not be able to use the Update Statements feature.", vbInformation, "Sorry..."
Exit Sub

Case vbOK
Application.ScreenUpdating = False
Application.DisplayAlerts = False
FName = "Financial_Model_" & Format(Now, "mmddyy")
Application.Dialogs(xlDialogSaveAs).Show FName

Application.StatusBar = "Please wait while the model is being updated..."
Sheets("Start").Visible = True
Sheets("End").Visible = True

On Error GoTo Xit

With ThisWorkbook.Worksheets("Index")
    
    ' Assuming 6 header rows and first department appears on row 7
    ' Sorting departments on Index, allowing up to 60 entries
    .Range("A7:AC66").Select
    Selection.Sort Key1:=Range("C7"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    LastDept = .Range("B65536").End(xlUp).Row
    
    ' Looking to add sheets here and looping through all entries on Index
    ' Assuming 6 header rows and first department appears on row 7
    For i = 7 To LastDept
        SheetExists = False
        For j = 1 To Worksheets.Count
            ' If true, then sheet exists and exits loop
            ' MsgBox Sheets(j).Name & " - " & .Cells(i, 3)
            If (Sheets(j).Name = .Cells(i, 3)) Then
                SheetExists = True
                Exit For
            End If
        Next j
        If (SheetExists = False) Then
            NewDeptName = .Cells(i, 3)
            NewDeptLName = .Cells(i, 2)
            ' Assuming 6 header rows and first department appears on row 7
            Sheets("DeptIS").Copy Before:=Sheets("End")
            With ActiveSheet
            .Name = NewDeptName
            .[B5].Value = NewDeptLName
            .Visible = True
            End With
        End If
    Next i
    
' Looking for sheets which, not being listed in Index, should be deleted here
ReStart:
    For i = 1 To Worksheets.Count
        SheetExists = False
        ' Making exceptions to sheets not on Index that should not be deleted
        If (Sheets(i).Name = "Input") Or (Sheets(i).Name = "Index") Or _
            (Sheets(i).Name = "Inflation") Or (Sheets(i).Name = "IPRollup") Or _
            (Sheets(i).Name = "OPRollup") Or (Sheets(i).Name = "FinStmt") Or _
            (Sheets(i).Name = "DeptIS") Or (Sheets(i).Name = "Start") Or _
            (Sheets(i).Name = "End") Or (Sheets(i).Name = "YTD") Then
            SheetExists = True
        Else
            ' Assuming 6 header rows and first department appears on row 7
            For j = 7 To LastDept
                If (Sheets(i).Name = .Cells(j, 3)) Then
                    SheetExists = True
                    Exit For
                End If
            Next j
            If (SheetExists = False) Then
                Sheets(i).Delete
                GoTo ReStart
            End If
        End If
    Next i
    
End With


Xit:
    Sheets("Start").Visible = False
    Sheets("End").Visible = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Sheets("Index").Activate
    Range("A1").Select
    ' ***Need more consideration on this Save***
    ActiveWorkbook.Save

    If Err.Number <> 0 Then
        ErrMsg = "Error:" & Str(Err.Number) & " was generated. " _
            & Err.Source & Chr(13) & Err.Description
        MsgBox ErrMsg, , "Ooops...", Err.HelpFile, Err.HelpContext
        MsgBox "Processing will now be terminated. Please save your work."
        Err.Clear
    Else
        MsgBox "All departmental income statements have been updated."
    End If

End Select

End Sub

I have at least 3 problems listed in order of importance:

1. This macro takes way too long to execute. Maybe the codes could be made more efficient. Maybe because the template worksheet ("DeptIS") that is used for copying new sheets has way too many CSE formulas in it that I'm currently using to populate data. It's hard to quantify the wait time but it's long enough time to make anyone thinks that it's crashing the PC.
--> Need help in making existing codes more efficient.

2. I'm currently getting the data from another workbook. In the data workbook, I have created several MS queries for the workbook to group relevant data together. Let's say I have a worksheet for each year of data and I need YTD plus 3 years of historical numbers. I create the same 4 sheets in the above model workbook and link it to the identical sheets in the data workbook. Then I use a bunch of array formulas (e.g. {=sum((dept="admin")*(acct="salaries")*end_bal)} to populate individual cells in each worksheet as it is generated by the above macros.
--> Need help in replacing the existing array formulas with VBA codes.

3. As more sheets are created, I get the 1004 run-time error. I did some researching and discovered that it is a known problem. I have looked at the workaround codes posted on the Microsoft KB and I have yet to adapt to my existing codes. I'm still working on this piece.
--> http://support.microsoft.com/default.aspx?scid=kb;en-us;210684

Any with any of the above would be greatly appreciated!!


Virginia

 

[Barrie Davidson]

Wow

Question 1 & 2. The code looks pretty efficient already. CSE formulas (or is it formulae) will surely slow down any workbook so if you can get rid of them, do it. One way might be to use SUMPRODUCT (and I'm not even sure if it makes the calculation quicker as I have not used a spreadsheet with many CSE formulae, but I think it is quicker). Something like:
=sumproduct((dept="admin")+0,(acct="salaries")+0,end_bal)
will replace your CSE formula.
Where I've had a spreadsheet that was getting large with formulae, I created a macro that put the formula in the appropriate ranges, copied the ranges, and then pasted values in those ranges. This made my spreadsheet's size go from over 10mb to under 3mb.

Question 2. Would need more information before being able to provide a VBA solution. For example, what are the formulae? where is the formulae put?

Question 3. Each time you copy a worksheet, put a save statement after it. Something like

Sheets("DeptIS").Copy Before:=Sheets("End")
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True

Hope this provides some assistance.

 

[detangler]

Hi Barrie,

Thanks for the response. I'm now testing to see if sumproduct instead of array formulas would speed up the process or not. I'll post back with the test result as well as more information regarding question #2. Thanks again!!

Virginia

 

[detangler]

Here's the test result: replacing array formulas with sumproduct has no effect on time. I inserted a couple of lines in the codes to keep track of the total time the macro took to run and both versions turned out to be the same.

I also inserted the line "ActiveWorkbook.Save" after each sheet copy and it didn't fix the problem. Around the 30th time a sheet was copied, the 1004 run-time error appeared. According to the MS KB post, the workaround is to save, close and reopen the workbook. Like I said earlier, I have yet to incorporate the workaround into my codes.

Regarding question #2, DeptIS (the worksheet template that is used to generate other worksheets) looks like this:

Financial_Model_v3.0.xls
	B	C	D	E	F
6		2001	2002	2003	YTD 2004
7	Revenue:
8	Inpatient Charges	0	0	0	0
9	Outpatient Charges	0	0	0	0
10	Net Patient Revenues	0	0	0	0
11	Other Operating Revenue	0	0	0	0
12	Expenses:
13	Salaries & Wages	0	0	0	0
14	Benefits	0	0	0	0
15	Supplies & Pharmaceuticals	0	0	0	0
16	Prof. Fees & Purch. Srvcs.	0	0	0	0
17	Other Variable Expenses	0	0	0	0
18	Utilities	0	0	0	0
19	Food Services	0	0	0	0
20	Interest	0	0	0	0
21	Depreciation	0	0	0	0
22	Other Fixed Expenses	0	0	0	0
DeptIS

As you can see, columns C, D, E, F, reference worksheets HYR1, HYR2, HYR3, and YTD. These four worksheets are in turn link to another workbook that stores data and MS queries. Depending on the name of the department (DeptIS!$B$5, not shown here) and the revenue/ expense item, the formula grabs the correct value from the relevant worksheet and fill it in.

In theory, this works. However.... all the linking and referencing have now made my workbook a 50MB monstrosity!!! There is no way that my users would want to run this model. Most of them work off of a laptop and that means it will most certainly crash or freeze their machines before it does any good.

I think replacing the formulas in DeptIS will help reduce the file size tremendously. I wish to fill in the values as a new sheet is generated using VBA codes. Better yet, I'd like to know how to get these values directly from the data workbook instead of referencing the duplicates in this model workbook.

Please let me know if I have not explained my problem clearly. Your help is greatly appreciated!

Virginia

 

[detangler]

Hi, anyone.... help?

 

[detangler]

I would still need some help here please!!

The problem in #1 is directly related to the situation in #2. I decided to get rid of all of the external linking of the 4 sheets (HYR1, HYR2, HYR3, YTD) to my data file and just pasting the data manually into them. It reduces the file size to around 350KB (that is before running the macro which generates additional sheets).

Population of data into individual sheet is now accomplished by a sub procedure; the actual code is too long to post because I’m not sure how to put it in a loop yet… here’s a partial code:

Sub AssignVal()
' To assign values to individual departmental income statement
' Formulae are converted to values to reduce file size
    
With ActiveSheet
' Populating historical year 1 (column D) numbers
        Range("D16").FormulaR1C1 = _
            "=SUMPRODUCT((HYR1!R2C2:R65536C2=R5C2)+0,(HYR1!R2C4:R65536C4=RC2)+0,HYR1!R2C5:R65536C5)"
        Range("D16").Value = Range("D16").Value
        
        Range("D17").FormulaR1C1 = _
            "=SUMPRODUCT((HYR1!R2C2:R65536C2=R5C2)+0,(HYR1!R2C4:R65536C4=RC2)+0,HYR1!R2C5:R65536C5)"
        Range("D17").Value = Range("D17").Value
        
        Range("D21").FormulaR1C1 = _
            "=SUMPRODUCT((HYR1!R2C2:R65536C2=R5C2)+0,(HYR1!R2C4:R65536C4=RC2)+0,HYR1!R2C5:R65536C5)"
        Range("D21").Value = Range("D21").Value
        
        Range("D27").FormulaR1C1 = _
            "=SUMPRODUCT((HYR1!R2C2:R65536C2=R5C2)+0,(HYR1!R2C4:R65536C4=RC2)+0,HYR1!R2C5:R65536C5)"
        Range("D27").Value = Range("D27").Value
        
        Range("D28").FormulaR1C1 = _
            "=SUMPRODUCT((HYR1!R2C2:R65536C2=R5C2)+0,(HYR1!R2C4:R65536C4=RC2)+0,HYR1!R2C5:R65536C5)"
        Range("D28").Value = Range("D28").Value
        
        Range("D29").FormulaR1C1 = _
            "=SUMPRODUCT((HYR1!R2C2:R65536C2=R5C2)+0,(HYR1!R2C4:R65536C4=RC2)+0,HYR1!R2C5:R65536C5)"
        Range("D29").Value = Range("D29").Value
           
........
        
    End With
    
End Sub

Even with this clunky code in place, the model runs just fine.

Finally with problem #3, the resolution posted on MS KB is to incorporate this code:

Sub CopySheetTest()
    Dim iTemp As Integer
    Dim oBook As Workbook
    Dim iCounter As Integer

    ' Create a new blank workbook:
    iTemp = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set oBook = Application.Workbooks.Add
    Application.SheetsInNewWorkbook = iTemp

    ' Add a defined name to the workbook
    ' that RefersTo a range:
    oBook.Names.Add Name:="tempRange", _
        RefersTo:="=Sheet1!$A$1"

    ' Save the workbook:
    oBook.SaveAs "c:\test2.xls"

    ' Copy the sheet in a loop. Eventually,
    ' you get error 1004: Copy Method of
    ' Worksheet class failed.
    For iCounter = 1 To 275
        oBook.Worksheets(1).Copy After:=oBook.Worksheets(1)
        'Uncomment this code for the workaround:
        'Save, close, and reopen after every 100 iterations:
        If iCounter Mod 100 = 0 Then
            oBook.Close SaveChanges:=True
            Set oBook = Nothing
            Set oBook = Application.Workbooks.Open("c:\test2.xls")
        End If
    Next
End Sub

This code requires that a blank workbook be created then subsequent sheets be created from the new workbook. The closing and reopening is controlled by the macro residing in the original workbook. So, two workbooks should be running simultaneously in order to accomplish this. I’m not sure just how I could use this solution for my situation. I cannot just create a new workbook and add sheets to it. I need the original workbook to make everything else work.

 

[Barrie Davidson]

Hey, sorry for not getting on this sooner!

#1 - have you also tried turning off calculation before running your code (turning it back on at the end of your code)? This can make a big difference in running time.
#2 - what logic would you use to loop through your cells? It appears that you can't just start at D16 and continue down (what do you have in D18:D20?).
#3 - try this with your code (indicated with commenting), not tested:

Dim oBook As Workbook
Dim iCounter As Integer

Set oBook = ActiveWorkbook.FullName
'Your loop beginning
    iCounter = iCounter + 1
    'Your code
    If iCounter Mod 100 = 0 Then
        oBook.Close SaveChanges:=True
        Set oBook = Nothing
        Set oBook = Application.Workbooks.Open(oBook)
    End If
'Your loop ending

Hope this gets you where you need to get. :wink: