help with VBA/Macro

[James]

I have a Macro that essentially consolidates all the same data in column A,
then separates the worksheet into individual worksheets, named based on the
data form column A. It's pretty cool, and i thank whoever it was that wrote
it for me!

My next question is, how can i make the NEW spreadsheets retain the same
formatting as the original one that is being split?

here is the code, it's long:

Sub Regionalize()
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim wbk As Workbook
Dim rng As Range
Dim cell As Range
Dim lRow As Long
Dim sFileName As String
Dim sFolder As String
Dim sRegion As String


Set wks = Sheets("region")
Set rng = wks.Range("regiondata")
'Use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change this if
needed)

With wks
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True

'You see that the last two columns of the worksheet are used to make
a Unique list
'and add the CriteriaRange.(you can't use this macro if you use this
columns)
lRow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

sFolder = "\\Stpprj06\custserv"

For Each cell In .Range("IV2:IV" & lRow)
.Range("IU2").Value = cell.Value

'add a new wbk?
Set wbk = Workbooks.Add
Set wksNew = wbk.Sheets.Add

sRegion = CleanFileName(cell.Value)
wksNew.Name = sRegion

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=wksNew.Range("A1"), _
Unique:=False

'name / save the wbk

'get the folder
If sFileName = "" Then
sFileName = Application.GetSaveAsFilename(sFolder & "\" &
sRegion, , , "Save " & sRegion & " to...")
sFolder = ParseFolder(sFileName)

If sFileName = "False" Then
MsgBox "Processing Canceled"
Exit Sub
End If
End If

'define the file name
sFileName = sFolder & "\" & sRegion
If Right(sFileName, 4) <> ".xls" Then
sFileName = sFileName & ".xls"
End If


'save the workbook and close it
wbk.SaveAs sFileName
wbk.Close

're-initialize the object variables
Set wksNew = Nothing
Set wbk = Nothing


Next
.Columns("IU:IV").Clear
End With
End Sub



Public Function CleanFileName(ByVal a_sFileName As String) As String
If Len(a_sFileName) > 31 Then
a_sFileName = Replace(a_sFileName, " ", "")
End If

If Len(a_sFileName) > 31 Then
Dim l As Long
l = InStr(1, a_sFileName, "*", vbTextCompare)
If l > 0 Then
a_sFileName = Left(a_sFileName, l - 1)
End If
End If

a_sFileName = Replace(a_sFileName, "*", "_")




CleanFileName = a_sFileName

End Function


Public Function ParseFolder(a_sPath As String) As String
'returns the folder part of the path provided.

Dim lPos As Long

For lPos = Len(a_sPath) To 2 Step -1
If Mid(a_sPath, lPos, 1) = "\" Then
ParseFolder = Left(a_sPath, lPos - 1)
Exit Function
End If

Next


End Function

 

[Guest]

You could include code like this after the new worksheet has been added.
(I only completed the first few items, you probably get the picture). Of
course, you could leave out the pagesetup options you don't need copied over.

With wksnew.PageSetup
.PrintTitleRows = wks.PageSetup.PrintTitleRows
.PrintTitleColumns = wks.PageSetup.PrintTitleColumns
.PrintArea =wks.PageSetup.PrintArea
.LeftHeader =
.CenterHeader =
.RightHeader =
.LeftFooter =
.CenterFooter =
.RightFooter =
.LeftMargin =
.RightMargin =
.TopMargin =
.BottomMargin =
.HeaderMargin =
.FooterMargin =
.PrintHeadings =
.PrintGridlines =
.PrintComments =
.PrintQuality =
.CenterHorizontally =
.CenterVertically =
.Orientation =
.Draft =
.PaperSize =
.FirstPageNumber =
.Order =
.BlackAndWhite =
.Zoom =
.FitToPagesWide =
.FitToPagesTall =
End With

 

[James]

Hi JMB!
thanks for your reply,
The problem is that there could be up to 70 new spreadsheets added. That's
why I'd like to include code with the already existing VBA.

or is that what you mean to do with this?

i'm really not very good with VBA at all.

James