Group and Create New Sheets

[Guest]

I am going to have multiple values in column B (they will not be the same
every time) that look like the following

A B C....
Apple 328 ...
Orange 427 ...
Pear 328 ...
Grape 519 ...
Banana 427 ...

I will need the unique values (and the entire row) to create a new sheet
(i.e. Apple 328 and Pear 328 should create a new sheet named "328")

As I said, the numbers that create the groups in Column B will be different
every time.

 

[Bernie Deitrick]

K.I.S.S.,

Try the macro below, first selecting all your data and answering 2 when prompted.

HTH,
Bernie
MS Excel MVP


Sub ExportDatabaseToSeparateSheets()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")


Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
'These lines copy everything - including extra header rows
' and any SUBTOTAL formulas separated by blank row
'Uncomment them to use them
' myCell.Parent.Cells.SpecialCells(xlCellTypeVisible).Copy
' mySht.Range("A1").PasteSpecial xlPasteValues


'These are the default - only copy the database values
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

End Sub

 

[Guest]

An error message tells me that "Cannot rename a sheet to the same name as
another sheet, a referenced object library or a workbook reference by Visual
Basic"
Is it trying to create a new sheet for every row entry or did I forget to
change something?

 

[Bernie Deitrick]

It might be the numbering.

Try changing:

myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myCell.Value

to

myName = Worksheets(Format(myCell.Value,"0")).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myName

If that doesn't work, would adding a prefix to the number cause you problems?

If not, change the code to

myName = Worksheets("Sht " & Format(myCell.Value,"0")).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myName


HTH,
Bernie
MS Excel MVP

 

[Guest]

I still can't get it to rename the new sheet as the value in Column B. I
don't know how to fix this. I do really need the "group value" as the sheet
name (whether or not it has a prefix). It always goofs when it gets to:

Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myName

(And I have tried replacing myName with myCell.Value. It seems to work
when I put a specific name to the sheet like "Sheet 1", but as you can
imagine, it will not work when it gets around to creating the next sheet
because there is already a sheet named "Sheet 1")

Any ideas?

 

[Bernie Deitrick]

How many sheets are you starting with?
Do you already have a sheet with the name of the 'group value' prior to running the macro?
What kinds of strings do you have in the 'group value' column? Can you manually rename a sheet with
those values, or do they have invalid characters?

HTH,
Bernie
MS Excel MVP

 

[Guest]

I only start with one sheet. The name of this sheet doesn't have to be
special. The column that contains the "group values" will vary every time I
run the program. They are 3 digit numbers, ex: 246, 247, 248, 247, 247, 248,
....
Really, I guess the sheets don't have to be "named after" the specific value
of the group, however, each group of numbers must be on a different sheet.
Any ideas? I think I am chasing the impossible dream here, but thinking
about how easy this program will make life for me, it tends to keep me going.
Any help is of course appreciated!

 

[Bernie Deitrick]

I had never tried this with numbers as the key values. Use the fixed version below.

HTH,
Bernie
MS Excel MVP

Sub KISSNumberKeyValueExport()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")


Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1, 0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(CStr(myCell.Value)).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = CStr(myCell.Value)
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
'These lines copy everything - including extra header rows
' and any SUBTOTAL formulas separated by blank row
'Uncomment them to use them
' myCell.Parent.Cells.SpecialCells(xlCellTypeVisible).Copy
' mySht.Range("A1").PasteSpecial xlPasteValues


'These are the default - only copy the database values
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell

End Sub

 

[Guest]

This worked AWESOME! Life will be easier now! Thanks for your help!

 

[Bernie Deitrick]

You're welcome....thanks for letting me know that you got it to work.

Bernie
MS Excel MVP

 

[Guest]

Wait, now I have another problem!

How can I get all of these sheets to have the same formatting? I have a
particular header and margin setting that I need to print on each new sheet.
I figured out (the hard way) that you can't really set formatting on all
sheets at the same time.

Is there a way I could have it loop through each sheet and format?
Remember, the new sheets will have different names each time.

 

[Bernie Deitrick]

K.I.S.S.,

Use a macro like this, after you run the first one. Use the macro recorder to get the code, then
modify the code to work on each of the sheets in turn. Post your code if you have trouble.

Sub FormatKISSSheets()
Dim mySht As Worksheet
For Each mySht In ActiveWorkbook.Worksheets
'Formatting stuff here, using code like
mySht.Cells.NumberFormat = "0.00"
mySht.Range("A1:A10").Interior.ColorIndex = 3
mySht.Range("A1").EntireRow.RowHeight = 16
Next mySht
End Sub

 

[Guest]

I am afraid I don't know what you mean by using that type of code (still a
mere novice). I have the following formatting preferences:

ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Bold""&14D- RTE &A"
.RightHeader = "&""Arial,Italic""as of &D, &T"
.LeftFooter = _
"&""Arial,Italic""&12I understand ....." & Chr(10) & "" & Chr(10) &
"Signature:_____________________________________"
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1.25)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 1200
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 99
.PrintErrors = xlPrintErrorsDisplayed
End With


Columns("A:A").Select
Selection.ColumnWidth = 3.71

Columns("B:B").Select
Selection.EntireColumn.Hidden = True
Columns("C:C").Select
Selection.ColumnWidth = 6.14
Columns("D").Select
Selection.ColumnWidth = 21
Next mySht
End Sub

As you can probably tell, I used a macro to record the formatting. How am I
supposed to change it so it works with your code/module?

 

[Bernie Deitrick]

K.I.S.S.,

Without changing a bit of your macro code.

HTH,
Bernie
MS Excel MVP

Sub DoAllSheets()
For Each mySht In ActiveWorkbook.Worksheets
mySht.PageSetup.PrintArea = ""
With mySht.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Bold""&14D- RTE &A"
.RightHeader = "&""Arial,Italic""as of &D, &T"
.LeftFooter = _
"&""Arial,Italic""&12I understand ....." & Chr(10) & "" & Chr(10) &
"Signature:_____________________________________"
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1.25)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 1200
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 99
.PrintErrors = xlPrintErrorsDisplayed
End With

mySht.Columns("A:A").ColumnWidth = 3.71
mySht.Columns("B:B").EntireColumn.Hidden = True
mySht.Columns("C:C").ColumnWidth = 6.14
mySht.Columns("D").ColumnWidth = 21
Next mySht
End Sub

 

[Guest]

I think that worked! I still have to clean up some of the formatting, but it
looks great so far.
Thanks for all your help!