Logo 
Search:

MS Office Forum

Ask Question   UnAnswered
Home » Forum » MS Office       RSS Feeds

Code to create new wrksheet that totals the other wrksheets?

  Asked By: Francisca    Date: Oct 21    Category: MS Office    Views: 805
  

I have a file that contains x number of worksheets (the number of
worksheets may vary from month-to-month). All worksheets are set up
the same, though each contains different results. I'm trying to find a
way through VBA where a new worksheet is created (within the same
file) that totals certain lines from each of the worksheets (same rows
across worksheets). Does anyone happen to have code for this? I can
send a sample file, if need be.

Share: 

 

3 Answers Found

 
Answer #1    Answered By: Hisa Yoshida     Answered On: Oct 21

Yes. I've done this before. My free Excel add-in
(www.grbps.com/adddin.htm) contains the facility to create  new sheets
based on a range which is selected. It then turns these sheet names into
hyperlinks to open the new sheets. This is the code:

-------------------------------
Sub MakeNewSheet()

Dim strMain As String
Dim strAddress As String
Dim BadCharsCount As Integer
Dim DupeNameFlag As Boolean

On Error GoTo Err_MakeNewSheet

strMain = ActiveSheet.Name
For Each c In Selection
strAddress = c.Address
If Len(c.Value) = 0 Then
MsgBox "Empty cell at " & Replace(c.Address, "$", "")
Exit Sub
End If
If Len(c.Value) > 31 Then
MsgBox "Sheet name exceeds 31 characters at cell " &
Replace(c.Address, "$", "")
Exit Sub
End If
BadCharsCount = InStr(1, c.Value, ":") + _
InStr(1, c.Value, "\") + _
InStr(1, c.Value, "/") + _
InStr(1, c.Value, "?") + _
InStr(1, c.Value, "*") + _
InStr(1, c.Value, "[") + _
InStr(1, c.Value, "]")
If BadCharsCount > 0 Then
myAnswer = MsgBox("Illegal characters in proposed filename
at cell " & _
Replace(c.Address, "$", "") & "." & vbCrLf & "Do you
want me to fix it?", vbYesNo)
If myAnswer = vbNo Then
MsgBox "Halting execution at cell " & Replace(c.Address,
"$", "")
Exit Sub
End If
c.Value = Replace(c.Value, ":", "-")
c.Value = Replace(c.Value, "\", "-")
c.Value = Replace(c.Value, "/", "-")
c.Value = Replace(c.Value, "?", "-")
c.Value = Replace(c.Value, "*", "-")
c.Value = Replace(c.Value, "[", "-")
c.Value = Replace(c.Value, "]", "-")
End If
For Each d In Sheets
If c.Value = d.Name Then DupeNameFlag = True
Next d
If DupeNameFlag Then
MsgBox "Duplicate sheet name at cell " & Replace(c.Address,
"$", "")
Exit Sub
End If
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
strSubAddr = "'" & c.Value & "'!A1"
Sheets(strMain).Hyperlinks.Add c, "", strSubAddr, "Go to sheet",
c.Value
strSubAddr = "'" & strMain & "'!" & strAddress
ActiveSheet.Hyperlinks.Add ActiveSheet.Range("a1"), "",
strSubAddr, "Back to index", "Main Sheet"
Sheets(strMain).Select
Next c
Err_MakeNewSheet:
End Sub
--------------------------

Of course, this isn't quite what you want to do. You need to create one
new sheet, then in column A list the names of all sheets in the file  and
then in the next column lift your number  from that sheet. This code  will
do it for you:

--------------------------
Sub MakeSummrySheet()

Dim strMain As String
Dim strName As String

Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "Summary sheet"

Range("a1").Select

For Each c In Sheets
If c.Name <> "Summary sheet" Then
strName = c.Name
Selection.Value = c.Name
strMain = "='" & c.Name & "'!G10"
Selection.Offset(0, 1).Formula = strMain
Selection.Offset(1, 0).Select
End If
Next c
---------------------------

Simply replace the G10 reference with the cell which contains the total
on your sheets.

 
Answer #2    Answered By: Courtney Hughes     Answered On: Oct 21

Yes. I've done this before. My free Excel add-in
(www.grbps.com/adddin.htm) contains the facility to create  new sheets
based on a range which is selected. It then turns these sheet names into
hyperlinks to open the new sheets. This is the code:

-------------------------------
Sub MakeNewSheet()

Dim strMain As String
Dim strAddress As String
Dim BadCharsCount As Integer
Dim DupeNameFlag As Boolean

On Error GoTo Err_MakeNewSheet

strMain = ActiveSheet.Name
For Each c In Selection
strAddress = c.Address
If Len(c.Value) = 0 Then
MsgBox "Empty cell at " & Replace(c.Address, "$", "")
Exit Sub
End If
If Len(c.Value) > 31 Then
MsgBox "Sheet name exceeds 31 characters at cell " &
Replace(c.Address, "$", "")
Exit Sub
End If
BadCharsCount = InStr(1, c.Value, ":") + _
InStr(1, c.Value, "\") + _
InStr(1, c.Value, "/") + _
InStr(1, c.Value, "?") + _
InStr(1, c.Value, "*") + _
InStr(1, c.Value, "[") + _
InStr(1, c.Value, "]")
If BadCharsCount > 0 Then
myAnswer = MsgBox("Illegal characters in proposed filename
at cell " & _
Replace(c.Address, "$", "") & "." & vbCrLf & "Do you
want me to fix it?", vbYesNo)
If myAnswer = vbNo Then
MsgBox "Halting execution at cell " & Replace(c.Address,
"$", "")
Exit Sub
End If
c.Value = Replace(c.Value, ":", "-")
c.Value = Replace(c.Value, "\", "-")
c.Value = Replace(c.Value, "/", "-")
c.Value = Replace(c.Value, "?", "-")
c.Value = Replace(c.Value, "*", "-")
c.Value = Replace(c.Value, "[", "-")
c.Value = Replace(c.Value, "]", "-")
End If
For Each d In Sheets
If c.Value = d.Name Then DupeNameFlag = True
Next d
If DupeNameFlag Then
MsgBox "Duplicate sheet name at cell " & Replace(c.Address,
"$", "")
Exit Sub
End If
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
strSubAddr = "'" & c.Value & "'!A1"
Sheets(strMain).Hyperlinks.Add c, "", strSubAddr, "Go to sheet",
c.Value
strSubAddr = "'" & strMain & "'!" & strAddress
ActiveSheet.Hyperlinks.Add ActiveSheet.Range("a1"), "",
strSubAddr, "Back to index", "Main Sheet"
Sheets(strMain).Select
Next c
Err_MakeNewSheet:
End Sub
--------------------------

Of course, this isn't quite what you want to do. You need to create one
new sheet, then in column A list the names of all sheets in the file  and
then in the next column lift your number  from that sheet. This code  will
do it for you:

--------------------------
Sub MakeSummrySheet()

Dim strMain As String
Dim strName As String

Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "Summary sheet"

Range("a1").Select

For Each c In Sheets
If c.Name <> "Summary sheet" Then
strName = c.Name
Selection.Value = c.Name
strMain = "='" & c.Name & "'!G10"
Selection.Offset(0, 1).Formula = strMain
Selection.Offset(1, 0).Select
End If
Next c
---------------------------

Simply replace the G10 reference with the cell which contains the total
on your sheets.

 
Answer #3    Answered By: Hiroshi Yoshida     Answered On: Oct 21

You need just one extra line for the second column (I'm assuing it is
H10 below). Try this:

--------------------------
Sub MakeSummrySheet()

Dim strMain As String
Dim strName As String

Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "Summary sheet"

Range("a1").Select

For Each c In Sheets
If c.Name <> "Summary sheet" Then
strName = c.Name
Selection.Value = c.Name
strMain = "='" & c.Name & "'!G10"
Selection.Offset(0, 1).Formula = strMain
strMain = "='" & c.Name & "'!H10"
Selection.Offset(0, 2).Formula = strMain
Selection.Offset(1, 0).Select
End If
Next c

---------------------------

Creating the totals  can be done in code, but when it's only a couple of
clicks using the autosum button it hardly seems worth it!

 




Tagged: