transposing data via a VBA macro

Hi All,

Going to try and explain this the best way I can.

The attached sheet has data in sheet1 which needs to be transposed into sheet2 format (final outcome).
A VBA macro the macro running the rest of the work is not in the same worksheet as the data sheets are created each day and it is required that the macros are not sent with the final output to the user. This part I can do and the read of the text file is working fine (all be it a bit clunky due to lack of experience, but it works )

The following needs to be considered.
1) There may not be data for a weekday but the script needs to deal with that and continue.
2) The sheet2 needs to be in week order and date order.

Any help would be much appreciated.

Regards

stubyh

Try the attached.

Option Explicit

Sub test()
    Dim a, i As Long, ii As Long, dic As Object
    Dim e, s, v, t As Long, n As Long
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Sheets("sheet2").Cells.ClearContents
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For ii = 2 To UBound(a, 2) - 2
            For i = 2 To UBound(a, 1)
                If Not dic.exists(a(i, UBound(a, 2))) Then
                    n = n + 1
                    dic(a(i, UBound(a, 2))) = n
                End If
                If Not .exists(a(1, ii)) Then
                    Set .Item(a(1, ii)) = _
                    CreateObject("Scripting.Dictionary")
                    .Item(a(1, ii)).CompareMode = 1
                End If
                If Not .Item(a(1, ii)).exists(a(i, UBound(a, 2) - 1)) Then
                    Set .Item(a(1, ii))(a(i, UBound(a, 2) - 1)) = _
                    CreateObject("Scripting.Dictionary")
                End If
                .Item(a(1, ii))(a(i, UBound(a, 2) - 1)) _
                    (a(i, UBound(a, 2))) = a(i, ii)
            Next
        Next
        For Each e In .keys
            ReDim a(1 To .Item(e).Count + 1, 1 To dic.Count + 1)
            a(1, 1) = e: i = 1
            For Each s In dic
                i = i + 1
                a(1, i) = s
            Next
            i = 1
            For Each s In .Item(e).keys
                i = i + 1
                a(i, 1) = s
                For Each v In .Item(e)(s).keys
                    a(i, dic(v) + 1) = .Item(e)(s)(v)
                Next
            Next
            Sheets("sheet2").Cells(1, t + 2) _
            .Resize(UBound(a, 1), UBound(a, 2)).Value = a
            t = t + UBound(a, 2) + 1
        Next
    End With
    With Sheets("sheet2")
        .UsedRange.Columns.AutoFit
        .Activate
    End With
End Sub

as an option

Sub ertert()
Dim x, y(), i&, j&, k&, w&, wk$, ub&
With Sheets("Sheet1").Range("A1").CurrentRegion
    x = .Resize(.Rows.Count + 1).Value
End With: ub = UBound(x, 2) - 1: k = k + 1
ReDim y(1 To UBound(x, 1) / 7 + 2, 1 To (UBound(x, 2) - 3) * 9)
For j = 2 To ub - 1
    y(k, 9 * (j - 2) + 1) = x(1, j)
    For i = 1 To 7
        y(k, 9 * (j - 2) + 1 + i) = Format(i + 1, "ddd")
    Next i
Next j

For i = 2 To UBound(x, 1) - 1
    w = Weekday(x(i, 1), vbMonday): k = k + 1: wk = x(i, ub)
    For j = 2 To ub - 1: y(k, 9 * (j - 2) + 1) = wk: Next j
    Do
        For j = 2 To ub - 1
            y(k, 9 * (j - 2) + w + 1) = x(i, j)
        Next j
        i = i + 1: w = Weekday(x(i, 1), vbMonday)
    Loop While wk = x(i, ub): i = i - 1
Next i
With Sheets("Sheet2")
    .UsedRange.ClearContents
    .Range("B1").Resize(k, UBound(y, 2)).Value = y(): .Activate
End With
End Sub

Hi, sorry to mark this as unsolved but I need to ask further questions.

The original code from jindon is the one I am using, however I cant get it to go passed the 52 weeks, the sheet now contains two years worth of data and will continue to grow as the years progress. How do I make it so that it goes past the 52 weeks of the first year this case 2011 and then into 2012 data.

any help would be apreciated

regards

stubyh

to jindon and nilem

Many thanks for your responce both work excelent.

Regards

Stubyh

Try this one.

Option Explicit

Sub test()
    Dim a, i As Long, ii As Long, dic As Object
    Dim e, s, v, t As Long, n As Long, txt As String
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    Sheets("sheet2").Cells.ClearContents
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For ii = 2 To UBound(a, 2) - 2
            For i = 2 To UBound(a, 1)
                If Not dic.exists(a(i, UBound(a, 2))) Then
                    n = n + 1
                    dic(a(i, UBound(a, 2))) = n
                End If
                If Not .exists(a(1, ii)) Then
                    Set .Item(a(1, ii)) = _
                    CreateObject("Scripting.Dictionary")
                    .Item(a(1, ii)).CompareMode = 1
                End If
                txt = Join$(Array(Year(a(i, 1)), a(i, UBound(a, 2) - 1)), Chr(2))
                If Not .Item(a(1, ii)).exists(txt) Then
                    Set .Item(a(1, ii))(txt) = _
                    CreateObject("Scripting.Dictionary")
                End If
                .Item(a(1, ii))(txt)(a(i, UBound(a, 2))) = a(i, ii)
            Next
        Next
        For Each e In .keys
            ReDim a(1 To .Item(e).Count + 1, 1 To dic.Count + 1)
            a(1, 1) = e: i = 1
            For Each s In dic
                i = i + 1
                a(1, i) = s
            Next
            i = 1
            For Each s In .Item(e).keys
                i = i + 1
                a(i, 1) = Split(s, Chr(2))(1)
                For Each v In .Item(e)(s).keys
                    a(i, dic(v) + 1) = .Item(e)(s)(v)
                Next
            Next
            Sheets("sheet2").Cells(1, t + 2) _
            .Resize(UBound(a, 1), UBound(a, 2)).Value = a
            t = t + UBound(a, 2) + 1
        Next
    End With
    With Sheets("sheet2")
        .UsedRange.Columns.AutoFit
        .Activate
    End With
End Sub

jindon

many thanks for the quick responce,

regards

stubyh