Ah hah!
One of my spreadsheets here at home, had this macro, so you're in luck!
I suggest backing up eveything before testing this code in any shape,
way, or form.
Public Sub textPivotTable(colRng As String, rowRng As String, dataRng
As String, dataSht As String, pivotCell As String, pivotSht As String)
' Feel free to modify this as you wish.
' this sub will create a new pivot table at the cell listed in pivot
range
' the caveat is that it expects a one-to-one-to-one relationship of the
data.
' for each (col,row) there must only be one data or else it won't get
the right result.
' colRng = the range that the data to be used a column is in
' rowRng = the range that the data to be used a row is in
' dataRng = the range that the data to be used a data is in
' dataSth = the name of the worksheet with the data
' pivotCell = the cell that is the top left corner of the pivot table
' pivotSht = the worksheet where the pivot table will be
' Example:
Dim wb As Workbook
Dim wsData As Worksheet, wsPivot As Worksheet, wsTemp As Worksheet
Dim rTemp As Range, rPivot As Range, rRow As Range, rCol As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets(dataSht)
Set wsPivot = wb.Sheets(pivotSht)
Set wsTemp = wb.Sheets.Add
wsData.Range(colRng).Copy
wsTemp.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wsData.Range(rowRng).Copy
wsTemp.Range("B1").PasteSpecial xlPasteValuesAndNumberFormats
wsData.Range(dataRng).Copy
wsTemp.Range("C1").PasteSpecial xlPasteValuesAndNumberFormats
' sort the data for the column headers
wsTemp.Columns("A
").Sort Key1:=wsTemp.Range("A1"),
Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2:=xlSortNormal
' create the column headers
Set rTemp = wsTemp.Range("A1")
Set rPivot = wsPivot.Range(pivotCell)
Do While Not rTemp.Value = ""
If Not rTemp.Value = rPivot.Value Then
Set rPivot = rPivot.Offset(0, 1)
rPivot.Value = rTemp.Value
End If
' create a temporary column for searching later
rTemp.Offset(0, 3).Value = rTemp.Value & "|" & rTemp.Offset(0,
1).Value
Set rTemp = rTemp.Offset(1, 0)
Loop
' sort the data for the row headers
wsTemp.Columns("A
").Sort Key1:=wsTemp.Range("B1"),
Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2:=xlSortNormal
' create row headers
Set rTemp = wsTemp.Range("B1")
Set rPivot = wsPivot.Range(pivotCell)
Do While Not rTemp.Value = ""
If Not rTemp.Value = rPivot.Value Then
Set rPivot = rPivot.Offset(1, 0)
rPivot.Value = rTemp.Value
End If
Set rTemp = rTemp.Offset(1, 0)
Loop
' fill in the table
Set rCol = wsPivot.Range(pivotCell).Offset(0, 1)
Do While Not rCol.Value = ""
Set rRow = wsPivot.Range(pivotCell).Offset(1, 0)
Do While Not rRow.Value = ""
Set rPivot = Intersect(rRow.EntireRow, rCol.EntireColumn)
Set rTemp = wsTemp.Range("D
").Find(rCol.Value & "|" &
rRow.Value)
If Not rTemp Is Nothing Then rPivot.Value = rTemp.Offset(0,
-2).Value
Set rRow = rRow.Offset(1, 0)
Loop
Set rCol = rCol.Offset(0, 1)
Loop
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
End Sub
