VBA: transpose data

Hello experts,

I have the following data:

2015-07-21-22-02-13-Microsoft-Excel-non-

I would like to generate the following result with the same format bold and freeze pane for line 1 and green filled color and bold letter for last line:
2015-07-21-22-03-04-Microsoft-Excel-non-
I am aware that I could do this trough a pivot table however I need to perform this action frequently so I would like to have a vba combined with a pivot table if necessary to generate this result.


Due to the fact that this is just a template which means that Query count Contributor and Week columns can be in different position I would like to have a config sheet In which I specified where are the columns concerned.
2015-07-21-22-12-28-Microsoft-Excel-non-
Instead of changing the code I will just need to modify the Config sheet.
If the Column of Config sheet should be reported in numbers, this is fine with me.

Please find attached the xlsm file.

Thank you again for your help.
transpose-data.xlsm
LVL 1
LD16Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Robberbaron (robr)Commented:
are you indicating that the data columns may not be contiguous in some case ? the piviot table want them contiguous, or the Week and Contributor fields at any rate.

My method would be to create a temp pivot table as it does all the aggregation of Weeks and Contributors, then copy that to the output area as values and reformat it.

i did a macro record to test and is seems ok but does rely on the week and contributor columns being adjacent. Order doesnt matter.  needs cleanup before posting result.
0
LD16Author Commented:
Thank you for your comment.
Ok, if I understood columns reported in my example should be next to another that means if I add a new column between existing columns (Query, Contributor and Week) the code doesn't work even if I properly report column letter in Config sheet? If so, this is fine with me I will call another macro to have the three columns contiguous.
Thank you for your help.
0
Robberbaron (robr)Commented:
ok. here is my effort. test worksheet seems ok.  attached.

also i created named ranges for the config items.

it uses a temporary area 100 rows below the input range to create the pivot then clears it.

Option Explicit
'v1 robberbaron @ EE
Sub StartPivot()
    Dim rngResult As Range, rngInput As Range
    
    Set rngResult = Worksheets("Result").Cells(1, 1)
    
    ClearResults rngResult

    Dim ContribCol As Integer, WeekCol As Integer
    ContribCol = Asc(Sheets("Config").Range("Contributor").Value) - Asc("A") + 1
    WeekCol = Asc(Sheets("Config").Range("Week").Value) - Asc("A") + 1
    
    If Abs(ContribCol - WeekCol) <> 1 Then
        MsgBox "Contributor and Week columns are not adjacent"
        Exit Sub
    End If
    If (ContribCol > WeekCol) Then
        Dim iTmp As Integer
        iTmp = WeekCol
        WeekCol = ContribCol
        ContribCol = iTmp
    End If
    
    Dim rStart As Range
    Set rStart = Sheets("Input").Cells(1, ContribCol)
    Set rStart = Range(rStart, rStart.End(xlDown)).Resize(, 2)
    'Range(Selection, Selection.End(xlDown)).Select
    'rStart.Select
    
    LoadTempPivot rStart, rngResult
    
    FormatTable rngResult
    
End Sub
Sub ClearResults(outputrng As Range)
    Dim rSel As Range
    Set rSel = outputrng.Worksheet.UsedRange
    'outputrng.Worksheet.UsedRange.Clear
    rSel.ClearContents
    Range("A1:J11").Select
    rSel.Borders(xlDiagonalDown).LineStyle = xlNone
    rSel.Borders(xlDiagonalUp).LineStyle = xlNone
    rSel.Borders(xlEdgeLeft).LineStyle = xlNone
    rSel.Borders(xlEdgeTop).LineStyle = xlNone
    rSel.Borders(xlEdgeBottom).LineStyle = xlNone
    rSel.Borders(xlEdgeRight).LineStyle = xlNone
    rSel.Borders(xlInsideVertical).LineStyle = xlNone
    rSel.Borders(xlInsideHorizontal).LineStyle = xlNone
    With rSel.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With


End Sub
Sub LoadTempPivot(srcData As Range, outputrng As Range)

    Dim rngTmp As Range, shtInput As Worksheet, pt As PivotTable
    
    Set rngTmp = srcData.Offset(srcData.Rows.Count + 100, 0)
    'ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    '    "Input!R1C2:R17C3", Version:=xlPivotTableVersion12).CreatePivotTable _
    '    TableDestination:="Input!R12C5", TableName:="PivotTableTemp", DefaultVersion _
    '    :=xlPivotTableVersion12
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=srcData, _
         Version:=xlPivotTableVersion12).CreatePivotTable _
         TableDestination:=rngTmp, TableName:="PivotTableTemp", _
         DefaultVersion:=xlPivotTableVersion12
         
             
    Set shtInput = rngTmp.Worksheet
    
    Set pt = shtInput.PivotTables("PivotTableTemp")
    
    Set rngTmp = pt.TableRange2
    With pt.PivotFields("Contributor")
        .Orientation = xlRowField
        .Position = 1
    End With
    pt.AddDataField pt.PivotFields("Week"), "Count of Week", xlCount
        
    With pt.PivotFields("Contributor")
        .Orientation = xlColumnField
        .Position = 1
    End With
    With pt.PivotFields("Week")
        .Orientation = xlRowField
        .Position = 1
    End With

    pt.PivotSelect "", xlDataAndLabel, True

    pt.GrandTotalName = "Total"
 
    pt.PivotSelect "'Row Grand Total'", _
        xlDataAndLabel, True
        
    pt.CompactLayoutRowHeader = "Week"
    
    With pt.DataBodyRange
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Set rngTmp = pt.TableRange1.Offset(1, 0).Resize(pt.TableRange1.Rows.Count - 1)
    
    'rngTmp.Select
    
    rngTmp.Copy
    outputrng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Set outputrng = outputrng.Resize(rngTmp.Rows.Count, rngTmp.Columns.Count)
    'rngTmp.EntireRow.Delete shift:=xlUp
    shtInput.Range(pt.TableRange2.Address).Delete shift:=xlUp
    
    shtInput.Activate
    shtInput.Cells(1, 1).Select
    
End Sub

Sub FormatTable(rngResult As Range)
    Dim rTmp As Range

    rngResult.Rows(1).Font.Bold = True
    
    With rngResult
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    With rngResult.Rows(rngResult.Rows.Count)
        'Range("A18:E18").Select
        .Font.Bold = True
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 5287936
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
    'rngResult.Select
    rngResult.Borders(xlDiagonalDown).LineStyle = xlNone
    rngResult.Borders(xlDiagonalUp).LineStyle = xlNone
    With rngResult.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With rngResult.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With rngResult.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With rngResult.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With rngResult.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With rngResult.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    'show results
    rngResult.Worksheet.Activate
    rngResult.Cells(1, 1).Select
End Sub

Open in new window

transpose-data0.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

LD16Author Commented:
Sorry for the delay.
Thank you very much for your proposal.
I tested and it works I have some questions:
1-I see in line 64 that you use the following: R1C2:R17C3, so if I put more info bellow row 17 I need to change this range, is not a way to dynamically take into account the used range?
2-The same for line 62 in which you specified 100 rows,  we cannot do something dynamically instead of reporting an specific row number?

Thank you again for your help.
0
Robberbaron (robr)Commented:
Line 64 is commented out and so not in use. was for my testing.  the source range is dynamic.

I used 100 as a nominal offset.  could change to anything useful but has to be fixed somehow as it the area gets deleted at the end of process.  best process would probably be to add a new worksheet, place temp pivot there, then delete the worksheet. but seemed overkill.
0
LD16Author Commented:
Ok, got it, thank you again for your help and for your solution!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.