VBA TIPS
  Custom transfer

If you have a table like below and when you'd like to apply the PivotTable function to this table, the layout have to be changed to be suitable for the PivotTable function.

Here is an example for looping in an array. This program would change the layout of table from before to after as follows.


before after


Example

Place the following in a standard module.

Option ExplicitOption Base 1

Sub CustomTranspostion()
    Const msg1 = "Please select data range"    'Suit your needs
    Const msg2 = "Please select output cell"    'Suit your needs
    Dim buf, ret()    'For store value as array
    Dim lngRow As Long, intCol As Integer    'ubound for return
    Dim i As Long, j As Long, k As Long, l As Long    'Counter
    Dim rngInput As Range, rngOutput As Range

    On Error Resume Next
    Set rngInput = Application.InputBox(msg1, Type:=8)
    Set rngOutput = Application.InputBox(msg2, Type:=8)
    If rngInput Is Nothing Then Exit Sub
    If rngOutput Is Nothing Then Exit Sub
    On Error GoTo 0
    buf = rngInput.Value
    lngRow = UBound(buf, 1) - 1
    intCol = UBound(buf, 2) - 1
    j = 1

    'Loop - change here if you'd like to run this code
    '           on the data has more than 3 columns.
    For i = LBound(buf) To lngRow
        For k = 0 To intCol - 1
            If Not IsEmpty(buf(i + 1, 2 + k)) Then
                ReDim Preserve ret(intCol, j + k - l)
                ret(1, j + k - l) = buf(i + 1, 1)
                ret(2, j + k - l) = buf(1, 2 + k)
                ret(3, j + k - l) = buf(i + 1, 2 + k)
            Else
                l = l + 1
            End If
        Next
        j = j + intCol - l
        l = 0
    Next

    '// PLEASE NOTE:
    '// Application.Transpose has a limit of 5461
    '// items.(In case Not XL2002 and the later version).
    '// So if error will be shown, pls Transpose array
    '// by loop like this.

    rngOutput.Resize(UBound(ret, 2), intCol).Value = _
    TransposeArray(ret)

    Set rngInput = Nothing
    Set rngOutput = Nothing
End Sub

'// You don't need it when use this code in XL2002
'// But need to be available "Application.Transpose" part.

Function TransposeArray(ByVal arr)
    Dim a As Long, b As Long, buf()
    ReDim buf(UBound(arr, 2)UBound(arr, 1))
    For a = LBound(arr) To UBound(arr)
        For b = LBound(arr, 2) To UBound(arr, 2)
            buf(b, a) = arr(a, b)
        Next b
    Next a
    TransposeArray = buf
End Function




| HOME |
Copyright © cellmasters.net - colo's junk room All Right Reserved
Tips and Information about Microsoft Excel|Masaru Kaji aka Colo