Hi,
I have two questions for my project below. I have a table TblSales in B:G and I try to do the equivalent of the pivot in L5:P10 by storing and calculating values in an Array (I put it in L13 to show result)
[/URL][/IMG]
The result is very close but as you can see the People are not sort Aphabetically as in Pivot and my array is dimensioned as string, so numbers are texts. I tried to dim it as long or integer but I had error with the text values.
Here is the code, I highlight in red both questions
That is my first code with collection and array, so any tip on the code (certainly overcomplicated since it was build by correcting all possible errors we get in the learning phase) is also very welcome. Thanks in advance
I have two questions for my project below. I have a table TblSales in B:G and I try to do the equivalent of the pivot in L5:P10 by storing and calculating values in an Array (I put it in L13 to show result)
The result is very close but as you can see the People are not sort Aphabetically as in Pivot and my array is dimensioned as string, so numbers are texts. I tried to dim it as long or integer but I had error with the text values.
Here is the code, I highlight in red both questions
Code:
Sub ArrayInsteadPivot()
[COLOR=#008000]'Define path to data table[/COLOR]
Dim myTable As ListObject
ShSales.Activate
Set myTable = ActiveSheet.ListObjects("TblSAles")
[COLOR=#008000]'Set First Column[/COLOR]
'Get Region Unique Values
Dim Region As Variant
Dim Regions As Collection
Set Regions = New Collection
[COLOR=#008000] 'Loop through each Cell and Error on duplicate (add with same key)
[/COLOR]
On Error Resume Next
For Each Region In myTable.ListColumns(2).DataBodyRange
[COLOR=#FF0000]'Question1: how can I sort those entries alphabetically?[/COLOR]
[COLOR=#FF0000] Regions.Add Region, Region [/COLOR]
Next Region
On Error GoTo 0
[COLOR=#008000]'Set First Row[/COLOR]
[COLOR=#008000] 'Get Person Unique Values[/COLOR]
Dim Person As Variant
Dim Persons As Collection
Set Persons = New Collection
[COLOR=#008000] 'Loop through each Cell and Error on duplicate (add with same key)[/COLOR]
On Error Resume Next
For Each Person In myTable.ListColumns(3).DataBodyRange
Persons.Add Person, Person
Next Person
On Error GoTo 0
[COLOR=#008000]'Define Array (needs to use Redim instead of Dim to be abble to use variables, dim works only with constants 1,2,3,...)
[/COLOR][COLOR=#FF0000]' Question 2: how can I set up string for titles and long for data?[/COLOR]
[COLOR=#FF0000] ReDim MyArray(1 To Regions.Count + 2, 1 To Persons.Count + 2) As String [/COLOR]
Dim r As Long 'row
Dim c As Long 'column
For r = 1 To Regions.Count + 2
For c = 1 To Persons.Count + 2
[COLOR=#008000] 'First Row[/COLOR]
[COLOR=#008000] 'First Cell[/COLOR]
If (r = 1 And c = 1) Then
MyArray(r, c) = "Regions"
End If
[COLOR=#008000] 'Name of Person[/COLOR]
If (r = 1 And c > 1 And c < Persons.Count + 2) Then
MyArray(r, c) = Persons(c - 1)
End If
[COLOR=#008000] 'Last Cell first row[/COLOR]
If (r = 1 And c = Persons.Count + 2) Then
MyArray(r, c) = "Total"
End If
[COLOR=#008000] 'First Column[/COLOR]
[COLOR=#008000] 'Name of Regions[/COLOR]
If (r > 1 And r < Regions.Count + 2 And c = 1) Then
MyArray(r, c) = Regions(r - 1)
End If
[COLOR=#008000] 'Last Cell first column[/COLOR]
If (r = Regions.Count + 2 And c = 1) Then
MyArray(r, c) = "Total"
End If
[COLOR=#008000] 'Fill the sum per person per Region[/COLOR]
If (r > 1 And r < Regions.Count + 2 And c > 1 And c < Persons.Count + 2) Then
MyArray(r, c) = Application.WorksheetFunction.SumIfs(myTable.ListColumns(6).DataBodyRange, myTable.ListColumns(2).DataBodyRange, Regions(r - 1), myTable.ListColumns(3).DataBodyRange, Persons(c - 1))
End If
[COLOR=#008000] 'Fill Total per person[/COLOR]
If (r = Regions.Count + 2 And c > 1 And c < Persons.Count + 2) Then
MyArray(r, c) = Application.WorksheetFunction.SumIfs(myTable.ListColumns(6).DataBodyRange, myTable.ListColumns(3).DataBodyRange, Persons(c - 1))
End If
[COLOR=#008000] 'Fill Total per Regions[/COLOR]
If (r > 1 And r < Regions.Count + 2 And c = Persons.Count + 2) Then
MyArray(r, c) = Application.WorksheetFunction.SumIfs(myTable.ListColumns(6).DataBodyRange, myTable.ListColumns(2).DataBodyRange, Regions(r - 1))
End If
[COLOR=#008000] 'Fill Last cell Total[/COLOR]
If (r = Regions.Count + 2 And c = Persons.Count + 2) Then
MyArray(r, c) = Application.WorksheetFunction.Sum(myTable.ListColumns(6).DataBodyRange)
End If
Next c
Next r
[COLOR=#008000] 'Put Array from ActiveCell (L13)[/COLOR]
Range("L13").Activate
Dim aRow As Long
Dim aCol As Long
aRow = ActiveCell.Row
aCol = ActiveCell.Column
Range(ActiveCell, Cells(aRow + Regions.Count + 1, aCol + Persons.Count + 1)) = MyArray
End Sub