Copy adjacent Sheet and name from a list

G

GS

For the non read/write directly to ranges approach, make sure the top
of the code window has the following...

Option Explicit
Option Base 1

...and replace CopySheetAndNameCopies() with whichever of the following
you like...

Sub CopySheetAndNameCopies_v2()
Dim vNames, sFormulas, n&, k&
vNames = Sheets("Summary").Range("BreakdownList")

Application.ScreenUpdating = False
Sheets("Main Swb").Visible = True

For n = LBound(vNames) To UBound(vNames)
Sheets("Main Swb").Copy after:=Sheets("Summary")
ActiveSheet.Name = vNames(n, 1)
sFormulas = "='" & vNames(n, 1) & "'!G7"
Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,
1).Resize(1, 4) = sFormulas
Next 'n

Sheets("Main Swb").Visible = False
Application.ScreenUpdating = True
End Sub


Sub CopySheetAndNameCopies_v3()
Dim vNames, vFormulaRefs, vaFormulas(1, 4), n&, k&
vNames = Sheets("Summary").Range("BreakdownList")
vFormulaRefs = Array("G7", "H7", "I7", "J7")

Application.ScreenUpdating = False
Sheets("Main Swb").Visible = True

For n = LBound(vNames) To UBound(vNames)
Sheets("Main Swb").Copy after:=Sheets("Summary")
ActiveSheet.Name = vNames(n, 1)
For k = 1 To 4
vaFormulas(1, k) = "='" & vNames(n, 1) & "'!" & vFormulaRefs(k)
Next 'k
Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,
1).Resize(1, UBound(vaFormulas, 2)) = vaFormulas
Next 'n

Sheets("Main Swb").Visible = False
Application.ScreenUpdating = True
End Sub

...and take care to catch any line wraps. (All code is single lines)

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
C

Claus Busch

Hi Howard,

Am Mon, 8 Apr 2013 08:32:46 -0700 (PDT) schrieb Howard:
Funny though, I can read it and understand what its doing. That will be a good one to keep around and refer to.
Click to expand...

at the moment you have 4 rows in Summary with values. When will you run
the macro? If all 24 rows are filled?
If you run the macro now and later you make new entries and you will run
the macro again, you must test which sheets already exists.
Then you better try:

Sub CopyMainSwb()
Dim arrNames, n As Integer
Dim SheetExists As Boolean

Application.ScreenUpdating = False
With Sheets("Summary")
arrNames = .Range("C9:C32").SpecialCells(xlCellTypeConstants)

For n = LBound(arrNames) To UBound(arrNames)
On Error Resume Next
SheetExists = Not Sheets(arrNames(n, 1)) Is Nothing
If SheetExists = False Then
Sheets("Main Swb").Copy before:=Sheets("NOTES")
ActiveSheet.Name = arrNames(n, 1)
.Range("C9:C32").SpecialCells(xlCellTypeConstants) _
.Cells(n).Offset(, 1).Resize(1, 4) = _
"='" & arrNames(n, 1) & "'!G7"
End If
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus Busch
 
H

Howard

at the moment you have 4 rows in Summary with values. When will you run

the macro? If all 24 rows are filled?

If you run the macro now and later you make new entries and you will run

the macro again, you must test which sheets already exists.

Then you better try:



Sub CopyMainSwb()

Dim arrNames, n As Integer

Dim SheetExists As Boolean



Application.ScreenUpdating = False

With Sheets("Summary")

arrNames = .Range("C9:C32").SpecialCells(xlCellTypeConstants)



For n = LBound(arrNames) To UBound(arrNames)

On Error Resume Next

SheetExists = Not Sheets(arrNames(n, 1)) Is Nothing

If SheetExists = False Then

Sheets("Main Swb").Copy before:=Sheets("NOTES")

ActiveSheet.Name = arrNames(n, 1)

.Range("C9:C32").SpecialCells(xlCellTypeConstants) _

.Cells(n).Offset(, 1).Resize(1, 4) = _

"='" & arrNames(n, 1) & "'!G7"

End If

Next

End With

Application.ScreenUpdating = True

End Sub





Regards

Claus Busch
Click to expand...


Excellent point!

Up to now I just had a little macro that would delete the newly made sheets so I could go on about doing test with the codes. That issue was bound to come up once the sheet was in general use instead of testing and developing.

Thanks for the look-ahead.

Howard
 
G

GS

Revised to handle existing sheets...

Sub CopySheetAndNameCopies_v2()
Dim vNames, sFormulas, n&, k&
vNames = Sheets("Summary").Range("BreakdownList")

Application.ScreenUpdating = False
Sheets("Main Swb").Visible = True

For n = LBound(vNames) To UBound(vNames)
If Sheets(vNames(n, 1)) Is Nothing Then
Sheets("Main Swb").Copy after:=Sheets("Summary")
ActiveSheet.Name = vNames(n, 1): sFormulas = "='" & vNames(n, 1)
& "'!G7"
Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,
1).Resize(1, 4) = sFormulas
End If 'Sheets(vNames(n, 1)) Is Nothing
Next 'n

Sheets("Main Swb").Visible = False
Application.ScreenUpdating = True
End Sub

Sub CopySheetAndNameCopies_v3()
Dim vNames, vFormulaRefs, vaFormulas(1, 4)
Dim n&, k&
vNames = Sheets("Summary").Range("BreakdownList")
vFormulaRefs = Array("G7", "H7", "I7", "J7")

Application.ScreenUpdating = False
Sheets("Main Swb").Visible = True

For n = LBound(vNames) To UBound(vNames)
If Sheets(vNames(n, 1)) Is Nothing Then
Sheets("Main Swb").Copy after:=Sheets("Summary")
ActiveSheet.Name = vNames(n, 1)
For k = 1 To 4
vaFormulas(1, k) = "='" & vNames(n, 1) & "'!" & vFormulaRefs(k)
Next 'k
Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,
1).Resize(1, UBound(vaFormulas, 2)) = vaFormulas
End If 'Sheets(vNames(n, 1)) Is Nothing
Next 'n

Sheets("Main Swb").Visible = False
Application.ScreenUpdating = True
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
C

Claus Busch

Hi Garry,

Am Mon, 08 Apr 2013 14:38:11 -0400 schrieb GS:
If Sheets(vNames(n, 1)) Is Nothing Then
Click to expand...

you will get an error ^^^^^^

Sub CopyMainSwb()
Dim arrNames, n As Integer

Application.ScreenUpdating = False
With Sheets("Summary")
arrNames = .Range("C9:C32").SpecialCells(xlCellTypeConstants)

For n = LBound(arrNames) To UBound(arrNames)
On Error Resume Next
If Sheets(arrNames(n, 1)) Is Nothing Then
Sheets("Main Swb").Copy before:=Sheets("NOTES")
ActiveSheet.Name = arrNames(n, 1)
.Range("C9:C32").SpecialCells(xlCellTypeConstants) _
.Cells(n).Offset(, 1).Resize(1, 4) = _
"='" & arrNames(n, 1) & "'!G7"
End If
Next
End With
Application.ScreenUpdating = True
End Sub


Regards
Claus Busch
 
G

GS

Thanks, Claus! You're absolutely correct! (I got lazy<g>, my bad)...

Sub CopySheetAndNameCopies_v2()
Dim vNames, sFormulas, n&, k&
vNames = Sheets("Summary").Range("BreakdownList")

Application.ScreenUpdating = False
Sheets("Main Swb").Visible = True

For n = LBound(vNames) To UBound(vNames)
If not bSheetExists(vNames(n, 1)) Then
Sheets("Main Swb").Copy after:=Sheets("Summary")
ActiveSheet.Name = vNames(n, 1)
sFormulas = "='" & vNames(n, 1) & "'!G7"
Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,
1).Resize(1, 4) = sFormulas
End If 'Not bSheetExists
Next 'n

Sheets("Main Swb").Visible = False
Application.ScreenUpdating = True
End Sub

Sub CopySheetAndNameCopies_v3()
Dim vNames, vFormulaRefs, vaFormulas(1, 4)
Dim n&, k&
vNames = Sheets("Summary").Range("BreakdownList")
vFormulaRefs = Array("G7", "H7", "I7", "J7")

Application.ScreenUpdating = False
Sheets("Main Swb").Visible = True

For n = LBound(vNames) To UBound(vNames)
If not bSheetExists(vNames(n, 1)) Then
Sheets("Main Swb").Copy after:=Sheets("Summary")
ActiveSheet.Name = vNames(n, 1)
For k = 1 To 4
vaFormulas(1, k) = "='" & vNames(n, 1) & "'!" & vFormulaRefs(k)
Next 'k
Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,
1).Resize(1, UBound(vaFormulas, 2)) = vaFormulas
End If 'Not bSheetExists
Next 'n

Sheets("Main Swb").Visible = False
Application.ScreenUpdating = True
End Sub

Function bSheetExists(WksName) As Boolean
On Error Resume Next
bSheetExists = CBool(Len(ActiveWorkbook.Sheets(WksName).Name))
End Function

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
H

Howard

Thanks, Claus! You're absolutely correct! (I got lazy<g>, my bad)...



Sub CopySheetAndNameCopies_v2()

Dim vNames, sFormulas, n&, k&

vNames = Sheets("Summary").Range("BreakdownList")



Application.ScreenUpdating = False

Sheets("Main Swb").Visible = True



For n = LBound(vNames) To UBound(vNames)

If not bSheetExists(vNames(n, 1)) Then

Sheets("Main Swb").Copy after:=Sheets("Summary")

ActiveSheet.Name = vNames(n, 1)

sFormulas = "='" & vNames(n, 1) & "'!G7"

Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,

1).Resize(1, 4) = sFormulas

End If 'Not bSheetExists

Next 'n



Sheets("Main Swb").Visible = False

Application.ScreenUpdating = True

End Sub



Sub CopySheetAndNameCopies_v3()

Dim vNames, vFormulaRefs, vaFormulas(1, 4)

Dim n&, k&

vNames = Sheets("Summary").Range("BreakdownList")

vFormulaRefs = Array("G7", "H7", "I7", "J7")



Application.ScreenUpdating = False

Sheets("Main Swb").Visible = True



For n = LBound(vNames) To UBound(vNames)

If not bSheetExists(vNames(n, 1)) Then

Sheets("Main Swb").Copy after:=Sheets("Summary")

ActiveSheet.Name = vNames(n, 1)

For k = 1 To 4

vaFormulas(1, k) = "='" & vNames(n, 1) & "'!" & vFormulaRefs(k)

Next 'k

Sheets("Summary").Range("BreakdownList").Cells(n).Offset(,

1).Resize(1, UBound(vaFormulas, 2)) = vaFormulas

End If 'Not bSheetExists

Next 'n



Sheets("Main Swb").Visible = False

Application.ScreenUpdating = True

End Sub



Function bSheetExists(WksName) As Boolean

On Error Resume Next

bSheetExists = CBool(Len(ActiveWorkbook.Sheets(WksName).Name))

End Function
Click to expand...

I tried both these subs and as far as I can tell, they do everything needed, testing for already incorporated sheet and doing nothing if no sheet new name is added.

The function is puzzling to me. Can't read what it does.

My next task is to write some code that will delete the sheets that have been entered. I have a little snippet that does that now but it is containedto the generic four names I've been testing with. So I need to give some thought on how I get the myrid of names entered to make sheet for to a "bucket" so I can dump them en-mass if or when needed. Some names will be around for some time and others will come and go at a pace yet to be determined.. The names in column C will be duck soup but deleting a sheet that has thesame name as column C, I will have to burn some thought calories. I may be back for help on this but for now I'm off and thinking. As I am typing this it occurs to me maybe I only want to dump a few of the sheets and name not all. Thep plot thickens

Sure do like the codes.

Thanks.

Howard
 
G

GS

You're very welcome! Thanks for the feedback!

I have a few different ideas for how to manage deleting sheets, but
I'll wait while you brainstorm awhile.<g>

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
H

Howard

You're very welcome! Thanks for the feedback!



I have a few different ideas for how to manage deleting sheets, but

I'll wait while you brainstorm awhile.<g>
Click to expand...

Well, I came up with this pedestrain bit of code, but it only deletes the first sheet of the selected names and all of the names selected then errors out with sub script out of range. Booger!

Option Explicit

Sub DeleteSelectSheet()
Dim c As Range
For Each c In Selection
Application.DisplayAlerts = False
Sheets(c.Value).Delete
Selection.ClearContents
Application.DisplayAlerts = True
Next
End Sub

Howard
 
C

Claus Busch

Hi Howard,

Am Mon, 8 Apr 2013 23:54:20 -0700 (PDT) schrieb Howard:
Well, I came up with this pedestrain bit of code, but it only deletes the first sheet of the selected names and all of the names selected then errors out with sub script out of range. Booger!
Click to expand...

same as add sheets:

Sub DeleteSheets()
Dim arrNames
Dim n As Integer

Application.DisplayAlerts = False
arrNames = Selection
For n = LBound(arrNames) To UBound(arrNames)
Sheets(arrNames(n, 1)).Delete
Selection.Resize(, 5).ClearContents
Next
Application.DisplayAlerts = True
End Sub


Regards
Claus Busch
 
H

Howard

same as add sheets:



Sub DeleteSheets()

Dim arrNames

Dim n As Integer



Application.DisplayAlerts = False

arrNames = Selection

For n = LBound(arrNames) To UBound(arrNames)

Sheets(arrNames(n, 1)).Delete

Selection.Resize(, 5).ClearContents

Next

Application.DisplayAlerts = True

End Sub





Regards

Claus Busch
Click to expand...

Code is in a module and I get an error on this line.
Tried it in the Summary sheet vb editor first and same error.

For n = LBound(arrNames) To UBound(arrNames)

Howard
 
H

Howard

Code is in a module and I get an error on this line.

Tried it in the Summary sheet vb editor first and same error.



For n = LBound(arrNames) To UBound(arrNames)



Howard
Click to expand...

The error is a type missmatch, sorry forgot to say in the other post.
 
C

Claus Busch

Hi Howard,

Am Mon, 8 Apr 2013 23:54:20 -0700 (PDT) schrieb Howard:
For Each c In Selection
Application.DisplayAlerts = False
Sheets(c.Value).Delete
Selection.ClearContents
Application.DisplayAlerts = True
Next
Click to expand...

because you ClearContents into the For-Next-Statement.
So there is no other name left.
In Code below the last line will sort that you don't have empty rows.
Try:

Sub DeleteSheets()
Dim rngC As Range

Application.DisplayAlerts = False
For Each rngC In Selection
Sheets(rngC.Text).Delete
Next
Selection.Resize(, 5).ClearContents
Range("C8:G32").Sort key1:=[C9], order1:=xlAscending, Header:=xlYes
Application.DisplayAlerts = True
End Sub


Regards
Claus Busch
 
H

Howard

Hi Howard,



Am Mon, 8 Apr 2013 23:54:20 -0700 (PDT) schrieb Howard:


For Each c In Selection
Click to expand...
Application.DisplayAlerts = False


Application.DisplayAlerts = True
Click to expand...
Next
Click to expand...



because you ClearContents into the For-Next-Statement.

So there is no other name left.

In Code below the last line will sort that you don't have empty rows.

Try:



Sub DeleteSheets()

Dim rngC As Range



Application.DisplayAlerts = False

For Each rngC In Selection

Sheets(rngC.Text).Delete

Next

Selection.Resize(, 5).ClearContents

Range("C8:G32").Sort key1:=[C9], order1:=xlAscending, Header:=xlYes

Application.DisplayAlerts = True

End Sub





Regards

Claus Busch
Click to expand...


I tried the code in the sheet vb editor and it deleted the sheets but the names and formulas to the right remain intact.

Produces a error 400

I tried the code in a module and the sheet are deleted and the names and formula remain intact.

errors out on this line yellow hi-light
Selection.Resize(, 5).ClearContents

Howard
 
C

Claus Busch

Hi Howard,

Am Tue, 9 Apr 2013 02:47:53 -0700 (PDT) schrieb Howard:
I tried the code in the sheet vb editor and it deleted the sheets but the names and formulas to the right remain intact.
Click to expand...

that is when the selected cells are not connected.
Place the code in a standard module.
Try:

Sub DeleteSheets()
Dim rngC As Range

Application.DisplayAlerts = False
For Each rngC In Selection
Sheets(rngC.Text).Delete
rngC.Resize(, 5).ClearContents
Next
Range("C8:G32").Sort key1:=[C9], order1:=xlAscending, Header:=xlYes
Application.DisplayAlerts = True
End Sub


Regards
Claus Busch
 
G

GS

I'm not working on this at the moment but I have given your project
some thought for improving the various processes particular to the way
the project works.

The 1st thing I'd change is the formulas to the right of the names list
so the cells are blank if the name col is blank. This will obviate the
need to program adding the formulas and thus reduce code (and related
maintenance). The sheetname within the formula can be a ref to the
names list col...

example:
=IF(LEN(Sheetname),"'"&Sheetname&"'!G7","")

...where Sheetname is a local scope col-absolute/row-relative defined
name that refs the names list col.

Revising the formulas will simplify removing names from the list
because the formula cols to the right will auto-adjust accordingly. The
list can be resorted so names are contiguous.

Since the table is fixed size, your template can persist the formulas
AND will benefit ongoing maintenance if you include defined names for
all ranges that might be ref'd in formulas/code.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

I forgot to wrap the text for the sheetname ref in the formula for the
cols right of names list on Summary in INDIRECT(). The following
works...

=IF(LEN(Sheetnames),INDIRECT("'"&Sheetnames&"'!G7"),"")

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

The col name defs are as follows...

colC: "Sheetname" RefersTo: =Summary!$C9
colD: "LabHrs" RefersTo: =Summary!$D9
colE: "LabCost" RefersTo: =Summary!$E9
colF: "MatlCost" RefersTo: =Summary!$F9
colG: "Sell" RefersTo: =Summary!$G9
colI: "SellPlus" RefersTo: =Summary!$CI9

...as defined after selecting any cell in row9.

The total (Q36) is named "Total". Its RefersTo is fully absolute.

The col formulas for the fixed table are as follows:

colD: =IF(LEN(Sheetname),INDIRECT("'"&Sheetname&"'!G7"),"")
colE: =IF(LEN(Sheetname),INDIRECT("'"&Sheetname&"'!H7"),"")
colF: =IF(LEN(Sheetname),INDIRECT("'"&Sheetname&"'!I7"),"")
colG: =IF(LEN(Sheetname),INDIRECT("'"&Sheetname&"'!J7"),"")
colI: =IF(LEN(Sell),Sell+(Total/24),"")

Given the structure of this sheet 'as is', adding new rows to the table
will need to be done manually. I probably would have designed this
sheet so a blank row could be stored (hidden) at the top of the sheet
so I can insert as needed for adding more names. Unfortunately, for
this to work would require relocating the area to the right of the
table so it's above the table in frozen pane area. This approach would
make removing names a simple matter of deleting entire rows, leaving no
required extraneous cleanup processing to do. If you're interested to
review a working copy of this let me know where to send/upload a file.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
H

Howard

Hi Howard,



Am Tue, 9 Apr 2013 02:47:53 -0700 (PDT) schrieb Howard:


I tried the code in the sheet vb editor and it deleted the sheets but the names and formulas to the right remain intact.
Click to expand...



that is when the selected cells are not connected.

Place the code in a standard module.

Try:



Sub DeleteSheets()

Dim rngC As Range



Application.DisplayAlerts = False

For Each rngC In Selection

Sheets(rngC.Text).Delete

rngC.Resize(, 5).ClearContents

Next

Range("C8:G32").Sort key1:=[C9], order1:=xlAscending, Header:=xlYes

Application.DisplayAlerts = True

End Sub





Regards

Claus Busch
Click to expand...

I'm having success with this code, which seems to be identical to the previous. Makes me think I may be doing stuff at my end and getting errors and maybe it is not the code at all. Forgetting to select the sheet names to be selected before running the code is one example.

I'm thinking I see a problem when I select from a list of 10 names,
say the 4th, 7th, 9th and run delete code it kinda messes up, but I need togather real specifics before I come to you with that. Using single digit numbers as sheet names may also be a problem. But applying strict do's anddon't rules for use of codes to the end user seems reasonable to me.

Thanks, Claus

I'll bat it around
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Create Sheets from a Range and Copy Data on copy Data on newlycreated Sheets with the Sheet Names 2
Add sheet and name it unless it already exists 12
Unhide sheet, copy and rename new sheets from list, rehide sheet 8
Hidden sheet bleeds through 3
Want code to copy to ABOVE row 22 column A on sheet 1 10
Copy Data From Varying Lines to One Sheet 1
Name the range AFTER copied to new sheet 6
Macro that can sort out a variabel name among others in a row and 0

Top