Transpose Table - Removing Duplicates

[arns]

Hi there.

I am trying to copy data from Table1 and add to Table2. After I run the Remove Duplicates code in Table1 for columns "Salesman" & "Project" I am left with 6 unique rows:
20774

I would like to add Header Range from Table1 to this unique rows in Table2. With current data in Table1 I should end up with 24 rows in Table2. This is where I am stuck, See code inside attachment.
20775

[arns]

1. My header row from Table 1 (the tasks I've chosen are 4):
20780
I would like to take the range("Table1[[#Headers],[Formula Task 1]:[Formula Task 18]]").

2. Remove duplicates from the selected two Columns in Table1 and I end up with this (6 unique rows):
20779
Range("Table1[[#All],[Salesman]:[Project]]")

3. This is want i want as an end result to my problem, pasted in Table2 (4 x 6 = 24 rows):
20781

If I the no. of Salesman, Project or Task in Table1 are changed; then the end result in Table2 will also change.

Can anybody help me with this?

[mancubus]

can you post your workbook?

[arns]

Here it is: 20793

[p45cal]

The attached has a button on Sheet1 that runs this code, which I think is what you're after:
Sub blah()
Set DestnSht = Sheets("Sheet2")
DestnSht.Cells.Clear
Set pt = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Table1").CreatePivotTable(TableDestination:=DestnSht.Cells(1))
With pt
.ManualUpdate = True
.ShowDrillIndicators = False
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False
For Each pf In pt.PivotFields 'turn off subtotals:
'First, set index 1 (Automatic) to True,
'so all other values are set to False
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
.RepeatAllLabels xlRepeatLabels
.PivotFields("Salesman").Orientation = xlRowField
.PivotFields("Project").Orientation = xlRowField
'the next 4 lines are currently hard-coded - it's likely they can be soft coded both in number and name:
.AddDataField .PivotFields("Formula Task 1"), "Sum of Formula Task 1", xlSum
.AddDataField .PivotFields("Formula Task 2"), "Sum of Formula Task 2", xlSum
.AddDataField .PivotFields("Formula Task 3"), "Sum of Formula Task 3", xlSum
.AddDataField .PivotFields("Formula Task 18"), "Sum of Formula Task 18", xlSum
With .DataPivotField
.Orientation = xlRowField
.Position = 1
End With
.PivotFields("Month").Orientation = xlColumnField
.ManualUpdate = False
End With 'PT
'enable the following 4 lines if you want to convert pivot table to plain values:
'Set myRng = PT.TableRange2
'myRngVals = myRng.Value
'myRng.ClearContents
'myRng.Value = myRngVals
DestnSht.Columns("A:A").EntireColumn.AutoFit
Application.Goto DestnSht.Range("A2")
End Sub
Things to be put right are the automation of which columns of Table1 to use to populate the leftmost column of the results and to correct their names (remove the likes of Sum of).

If you want to do this manually, step through the code with F8 observing what happens in the Pivot Table Field List pane.

[p45cal]

Consider changing:
'the next 4 lines are currently hard-coded - it's likely they can be soft coded both in number and name:
.AddDataField .PivotFields("Formula Task 1"), "Sum of Formula Task 1", xlSum
.AddDataField .PivotFields("Formula Task 2"), "Sum of Formula Task 2", xlSum
.AddDataField .PivotFields("Formula Task 3"), "Sum of Formula Task 3", xlSum
.AddDataField .PivotFields("Formula Task 18"), "Sum of Formula Task 18", xlSum to the likes of:
For Each pf In pt.PivotFields
If pf.Name Like "*Task*" Then
.AddDataField pf, Replace(pf.Name, "Formula", "F"), xlSum
End If
Next pf

[snb]

or:

Using Dictionary

Sub M_snb()
sn = Sheet1.ListObjects(1).Range

With CreateObject("scripting.dictionary")
For j = 2 To UBound(sn)
.Item(sn(j, 2) & sn(j, 3) & sn(1, 4)) = Array(sn(1, 4), sn(j, 2), sn(j, 3))
.Item(sn(j, 2) & sn(j, 3) & sn(1, 5)) = Array(sn(1, 5), sn(j, 2), sn(j, 3))
.Item(sn(j, 2) & sn(j, 3) & sn(1, 6)) = Array(sn(1, 6), sn(j, 2), sn(j, 3))
.Item(sn(j, 2) & sn(j, 3) & sn(1, 7)) = Array(sn(1, 7), sn(j, 2), sn(j, 3))
Next

Cells(1, 14).Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub

Applying only Arrays:


Sub M_snb()
sn = Sheet1.ListObjects(1).Range
ReDim sp(UBound(sn) * UBound(sn, 2), 2)

For j = 2 To UBound(sn)
For jj = 0 To 3
c00 = sn(j, 2) & sn(j, 3) & sn(1, 4 + jj)
If InStr(c01 & "|", "|" & c00 & "|") = 0 Then
sp(y, 0) = sn(1, 4 + jj)
sp(y, 1) = sn(j, 2)
sp(y, 2) = sn(j, 3)
y = y + 1
c01 = c01 & "|" & c00
End If
Next
Next

Cells(1, 20).Resize(UBound(sp) + 1, 3) = sp
End Sub

[p45cal]

If I the no. of Salesman, Project or Task in Table1 are changed; then the end result in Table2 will also change.The pivot table (actually pivotcache) will need to be refreshed for changes to show although this can be automated everytime the table is changed.

[arns]

Dear p45cal.

Thank you for your time. This is pretty close to what I am looking for. I do need the end result to be added to a table. Therefore I added the last for lines of the code to convert pivot table to plain values.

Current result:
20799

Is it possible to change the current result to something like this:
20800

arns

[p45cal]

Sub blah2()
Set DestnSht = Sheets("Sheet2")
DestnSht.Cells.Clear
Set PT = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Table1").CreatePivotTable(TableDestination:=DestnSht.Cells(1))
With PT
.ManualUpdate = True
.ShowDrillIndicators = False
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False
For Each pf In PT.PivotFields 'turn off subtotals:
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
.RepeatAllLabels xlRepeatLabels
.PivotFields("Salesman").Orientation = xlRowField
.PivotFields("Project").Orientation = xlRowField

For Each pf In PT.PivotFields
If pf.Name Like "*Task*" Then
'Stop
.AddDataField pf, Replace(pf.Name, "Formula ", "Formula¬"), xlSum 'changes a space to an unusual character (can't uses the same name as another pivot field). That character will be restored to a single space later.
End If
Next pf

' 'the next 4 lines are currently hard-coded - it's likely they can be soft coded both in number and name:
' .AddDataField .PivotFields("Formula Task 1"), "Formula¬Task 1", xlSum
' .AddDataField .PivotFields("Formula Task 2"), "Formula¬Task 2", xlSum
' .AddDataField .PivotFields("Formula Task 3"), "Formula¬Task 3", xlSum
' .AddDataField .PivotFields("Formula Task 18"), "Formula¬Task 18", xlSum
With .DataPivotField
.Orientation = xlRowField
.Position = 1
End With
.PivotFields("Month").Orientation = xlColumnField
.ManualUpdate = False
End With 'PT
Set myRng = PT.TableRange2
myRngVals = myRng.Value
myRng.ClearContents
myRng.Value = myRngVals
With Intersect(myRng, myRng.Offset(1)).Columns(1)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
.Replace What:="¬", Replacement:=" ", LookAt:=xlPart, SearchFormat:=False, ReplaceFormat:=False 'restores spaces.
End With
DestnSht.Columns("A:A").EntireColumn.AutoFit
Application.Goto DestnSht.Range("A2")
End Sub

[snb]

Sub M_snb()
sn = Sheet1.ListObjects(1).Range

With CreateObject("scripting.dictionary")
For j = 2 To UBound(sn)
For jj = 4 To 7
sp = Array(sn(1,jj), sn(j, 2), sn(j, 3), "", "", "", "", "", "", "", "", "", "", "", "")
c00 = sn(1, jj) & "_" & sn(j, 2) & "_" & sn(j, 3)
If .exists(c00) Then sp = .Item(c00)
sp(sn(j, 1) + 2) = Val(sp(sn(j, 1) + 2)) + sn(j, jj)
.Item(c00) = sp
Next
Next

Cells(1, 12).Resize(.Count, 15) = Application.Index(.items, 0, 0)
End With
End Sub

Or exclusively Arrays:

Sub M_snb()
sn = Sheet1.ListObjects(1).Range
ReDim sp(UBound(sn), 14)

For j = 2 To UBound(sn)
For jj = 4 To 7
For jjj = 0 To UBound(sp)
If sp(jjj, 0) & sp(jjj, 1) & sp(jjj, 2) = sn(1, jj) & sn(j, 2) & sn(j, 3) Or sp(jjj, 0) = "" Then Exit For
Next
sp(jjj, 0) = sn(1, jj)
sp(jjj, 1) = sn(j, 2)
sp(jjj, 2) = sn(j, 3)
sp(jjj, sn(j, 1) + 2) = sn(j, jj)
Next
Next

Cells(1, 12).Resize(UBound(sp), UBound(sp, 2)) = sp
End Sub

[arns]

Thank you, exactly what I was looking for. :)