help with/for pivottable code

[news]

Hi everyone!

I have code that takes a large workbook and divides it into a number of
separate new workbooks based on data that is in column A. What i need is to
create code that will create a pivot table in the new workbook.

here is my code:

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


Cells.Select
Cells.EntireColumn.AutoFit


'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


Thanks in advance,
James