J
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
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