VBA to transform semi-structured data into pivotable table (Solved)

[jasonleewkd]

Hi folks, I've got a sheet with semi-structured data. This current table can't be pivoted. I'm trying to 'transpose' the data into a table that can be pivoted. That will require a lot of manual work as I've got 276 headers and about 20 data points per header. I did some courses on VBA but this beats me. Does anyone have any idea on how to crunch this or help me get started?

 

[SirJB7]

Hi, jasonleewkd!

Give a look at this file:
https://dl.dropboxusercontent.com/u...le help (for jasonleewkd at chandoo.org).xlsm

This is the code:

Option Explicit

Sub Pivotingableing()
    ' constants
    Const ksSourceWS = "Unpivotable table"
    Const ksTargetWS = "Hoja1"
    ' declarations
    Dim rngS As Range, rngT As Range
    Dim I As Integer, J As Integer, K As Integer
    ' start
    Set rngS = Worksheets(ksSourceWS).Cells
    Set rngT = Worksheets(ksTargetWS).Cells
    rngT.ClearContents
    ' process
    '  titles
    I = 1
    With rngT
        .Cells(I, 1).Value = "Period"
        .Cells(I, 2).Value = "Blumberg ticker"
        .Cells(I, 3).Value = "Value"
    End With
    With rngS
        For J = 1 To .Columns.Count Step 3
            If .Cells(1, J).Value = "" Then Exit For
            I = I + 1
            If .Cells(3, J).Value <> "" And .Cells(3, J + 1).Value <> "" Then
                K = .Cells(3, J).End(xlDown).Row - 3 + 1
                Range(.Cells(3, J), .Cells(3, J).End(xlDown)).Copy rngT.Cells(I, 1)
                Range(rngT.Cells(I, 2), rngT.Cells(I + K - 1, 2)).Value = .Cells(1, J).Value
                Range(.Cells(3, J + 1), .Cells(3, J + 1).End(xlDown)).Copy rngT.Cells(I, 3)
            Else
                K = 0
            End If
            I = I + K - 1
        Next J
    End With
    ' end
    Set rngT = Nothing
    Set rngS = Nothing
    ' beep
    Beep
End Sub

Just advise if any issue.

Regards!

 

[Smallman]

Hi Jason

Try this

Option Explicit

Sub AreatoSht2()
    Dim rng As Range
    Dim sh As Worksheet
    Dim lr As Long
    Set sh = Sheet2
 
    For Each rng In Rows(1).SpecialCells(xlCellTypeConstants).Areas
        With rng.CurrentRegion
            sh.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count, .Columns.Count) = .Value
        End With
    Next
    'Clean it up
    lr = sh.Range("A" & Rows.Count).End(xlUp).Row
    sh.Columns("B:B").EntireColumn.Insert
    sh.Range("B2:B" & lr) = "=IFERROR(IF(FIND(""Index"",A2,1)>0,A2),B1)"
    sh.Range("B2:B" & lr).Value = sh.Range("B2:B" & lr).Value
    sh.Range("A3:A" & lr).AutoFilter 1, "=*e*"
    sh.Range("C4:C" & lr).EntireRow.Delete
    sh.Range("C3").AutoFilter
    sh.[A3:C3] = [{"Period", "Ticker", "Value"}]
End Sub

I will post a file to show workings.

Take care

Smallman