Macro for Looping Transposition

I am trying to reorganize a generated report in Excel. As you can see in the attachment (sheet 1 shows a sample of the report as it is generated while sheet 2 shows the desired result), most of the changes are not too difficult to make (deleting certain fields, transposing the headers, etc.). I have been able to successfully record a macro to make these changes. However, I am trying to figure out a way to program a looping macro to transpose the actual data (the entire report with actual data has 700+ rows). I know I can record a macro for this as well, but it is rather time consuming since I can only transpose 4 rows at a time. I'm hoping to code something which I can manipulate in the future in case I have to generate a report for more or less than the 7 days currently shown. I'm thinking that I can have two macros: 1 recorded for the layout changes and the other coded for the actual data transposition.

Thanks in advance for any assistance.

Hi Miroslav,
try this

Sub ertert()
Dim x, y(), i&, j&, k&
x = Sheets("Sheet1").Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x) * (UBound(x, 2) - 3), 1 To 6)
For i = 2 To UBound(x) Step 4
    For j = 4 To UBound(x, 2)
        If IsNumeric(x(i, j)) Then
            k = k + 1
            y(k, 1) = Val(x(i, 1))
            y(k, 2) = x(1, j): y(k, 3) = x(i, j)
            y(k, 4) = x(i + 1, j): y(k, 5) = x(i + 2, j)
            y(k, 6) = x(i + 3, j)
        End If
    Next j
Next i
With Sheets("Sheet2").Range("A2").CurrentRegion.Offset(1)
    .ClearContents
    .Resize(k, 6).Value = y()
End With
End Sub

Hi Nilem,

Thank you very much, that code is a great help. Would it be possible to include in the code a provision to maintain the format of the cells? For example, sheet 1 contains data in the format h:mm:ss, but when the macro is run, it reverts to the default general format.

Also, would you be willing to explain the code and how I can alter it in case the generated report changes in the future? For example, currently there are four different statistical measures: total calls, total hold time, total ACW, and total talk time. However, in the future, additional statistics may be added (they would be generated in the same format).


Spasiba bolshoye!

Hi Miroslav,
pre-format the entire columns in Sheet2 as needed (this should be done only once) and try this code:

Sub ertert()
Dim x, y(), i&, j&, k&, n&, u&, v&
x = Sheets("Sheet1").Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x) * (UBound(x, 2) - 3), 1 To 2): k = 2: n = 1
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(x)
        If .Exists(x(i, 3)) Then
            v = .Item(x(i, 3))
        Else
            k = k + 1: .Item(x(i, 3)) = k: v = k
            If k > UBound(y, 2) Then ReDim Preserve y(1 To UBound(y), 1 To k)
            y(1, v) = x(i, 3)
        End If
        For j = 4 To UBound(x, 2)
            If IsNumeric(x(i, j)) Then
                If Not .Exists(x(i, 1) & x(1, j)) Then
                    n = n + 1: .Item(x(i, 1) & x(1, j)) = n: u = n
                    y(u, 1) = Val(x(i, 1)): y(u, 2) = x(1, j)
                Else
                    u = .Item(x(i, 1) & x(1, j))
                End If
                y(u, v) = x(i, j)
            End If
        Next j
    Next i
End With
y(1, 1) = "Agent": y(1, 2) = "Date"
With Sheets("Sheet2").Range("A1")
    .CurrentRegion.ClearContents: .Resize(n, k).Value = y()
End With
End Sub

You can add as many statistical indicators, as needed

PS you have an excellent Russian-English language

Nilem,

This is amazing! Thank you again for your help. It is greatly appreciated.