shawn wang y.x.

Excel VBA Quick Reference 3: VBA Virtual Pivot Table on Arrays

By Swyx on December 15th, 2011

Also self explanatory?

Private Sub swyxVBAPivotTable(inputarray(), rowlabelsBase1(), valuedataBase1(), outputarray())
Dim x, y, i, j, sb, WIA
Dim prelimarray(), listofcols()
x = UBound(rowlabelsBase1)
y = UBound(valuedataBase1)
ReDim prelimarray(1 To x + y, 1 To 1)
ReDim listofcols(1 To 1)
‘just the first one, special treatment
      sb = “”
      For j = 1 To x
        sb = sb & inputarray(1, rowlabelsBase1(j))
      Next j
        listofcols(1) = sb
      For j = 1 To x
        prelimarray(j, 1) = inputarray(1, rowlabelsBase1(j))
      Next j
      For j = x + 1 To x + y
        prelimarray(j, 1) = inputarray(1, valuedataBase1(j – x))
      Next j
‘for the others, a bit more complicated…
For i = LBound(inputarray) + 1 To UBound(inputarray)
      sb = “”
      For j = 1 To x
        sb = sb & inputarray(i, rowlabelsBase1(j))
      Next j
      WIA = swyxWhereInArray(sb, listofcols)
      If WIA = False Then
        ‘add new column to both listofcols and prelimarray
        WIA = UBound(listofcols) + 1
        ReDim Preserve listofcols(1 To WIA)
        listofcols(WIA) = sb
        ReDim Preserve prelimarray(1 To x + y, 1 To WIA)
        For j = 1 To x
          prelimarray(j, WIA) = inputarray(i, rowlabelsBase1(j))
        Next j
      End If
      ‘add to existing data
        For j = x + 1 To x + y
            If IsNumeric(inputarray(i, valuedataBase1(j – x))) Then
                prelimarray(j, WIA) = prelimarray(j, WIA) + inputarray(i, valuedataBase1(j – x))
            Else
                If IsNull(prelimarray(j, WIA)) Or IsEmpty(prelimarray(j, WIA)) Then
                    prelimarray(j, WIA) = inputarray(i, valuedataBase1(j – x))
                Else
                    If swyxWhereInArray(inputarray(i, valuedataBase1(j – x)), Split(“filler, ” & prelimarray(j, WIA), “, “)) = False Then
                        prelimarray(j, WIA) = prelimarray(j, WIA) & “, ” & inputarray(i, valuedataBase1(j – x))
                    End If
                End If
            End If
        Next j
Next i
outputarray = WorksheetFunction.Transpose(prelimarray)
End Sub

Private Function swyxWhereInArray(thing, ArrayOfThings)
Dim i
For i = LBound(ArrayOfThings) To UBound(ArrayOfThings)
    If StrComp(CStr(ArrayOfThings(i)), CStr(thing), vbTextCompare) = 0 Then
        swyxWhereInArray = i
        Exit Function
    Else
        swyxWhereInArray = False
    End If
Next i
End Function