Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
help with/for pivottable code
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Pivottable code problem | Excel Discussion (Misc queries) | |||
Change PivotTable Field By Code | Excel Programming | |||
Pivottable code problem | Excel Programming | |||
How to have a Macro skip code if PivotTable/PivotField is not there | Excel Programming | |||
Streamline PivotTable creation code | Excel Programming |