Duplicate line and transpose data

Hi waterserv,
Thanks for helping. Your macro works very well.

Yes I want to put the result on the same worksheet. My idea is to save your code in a seperate xls file (e.g. Me.xls) in a module. It's like a repository of macros that I use daily. So this way, I don't have to repaste the macro in 4Q file when someone else updates it.

I open this Me.xls. Run your macro. The macro will launch a Open file dialogbox. I select the 4Q.xls file. It will look for the worksheet called "Original-Work", your "test" macro continue to update/change the data on the same "Original-Work" worksheet.

Thank you.

While you can use this macro, which will speed things up a lot, your manual technique could be simplified to a 1 time procedure rather than the 100 time procedure you are currently using.

When you need to 'fold data', the best way is to do blocks at a time, and use formulas to move the data. For example, this is how to process your table:

First, copy all your data (except the headers), and paste it below the existing data 3 times, so that you end up with each line repeated four times. Then sort your data based on column A. This will move the data together.

Then, insert two new columns, and label the first "C1" and the second "Qty Avg" and in rows 2 to 5 of C1, use these four formulas:

=D2 & "--Q1"
=D3 & "--Q2"
=D4 & "--Q3"
=D5 & "--Q4"

Where D is the column with the Class Number.

Then in "Qty Avg" and use these four formulas

=L2
=M3
=N4
=O5

Where L, M, N, and O are the quarter values.

Then copy those eight formulas to fill the two columns below. Copy both columns and pastespecial values, and delete the Average and quarter value columns. And you're done.

Anyway, here is the macro.

Option Explicit

Sub TestMacro()
    Dim R As Range
    Dim QCols(1 To 4) As Long
    Dim InfoCols(1 To 4) As Long
    Dim i As Integer
    Dim lngR As Long
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Test").Delete
    On Error GoTo 0
    
    ActiveSheet.Copy before:=Sheets(1)
    Sheets(1).Name = "Test"
    
    With Sheets("Test")
        With .Range("1:1")
            
            Set R = .Find("Average", LookAt:=xlWhole)
            R.Resize(1, 2).EntireColumn.Insert
            InfoCols(2) = R.Column - 2
            InfoCols(3) = R.Column - 1
            InfoCols(4) = R.Column
            
            .Cells(1, InfoCols(2)).Value = "C1"
            .Cells(1, InfoCols(3)).Value = "Qty Avg"
            
            Set R = .Find("Class Number", LookAt:=xlWhole)
            InfoCols(1) = R.Column
            
            For i = 1 To 4
                Set R = .Find("Q*" & i & "*", LookAt:=xlPart)
CheckQ:
                If MsgBox("Is this Q" & i & "? " & R.Value, vbYesNo) = vbYes Then
                    QCols(i) = R.Column
                Else
                    Set R = .FindNext(R)
                    GoTo CheckQ
                End If
            Next i
        End With
        
        For lngR = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
            .Cells(lngR, "A").EntireRow.Copy
            .Cells(lngR + 1, "A").Resize(3, 1).EntireRow.Insert
        Next lngR
        For lngR = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            .Cells(lngR, InfoCols(2)).Value = .Cells(lngR, InfoCols(1)).Value & "--Q" & ((lngR - 2) Mod 4) + 1
            .Cells(lngR, InfoCols(3)).Value = .Cells(lngR, QCols(((lngR - 2) Mod 4) + 1)).Value
        Next lngR
        .Columns(InfoCols(4)).Clear
        .Columns(QCols(1)).Clear
        .Columns(QCols(2)).Clear
        .Columns(QCols(3)).Clear
        .Columns(QCols(4)).Clear
    End With
    
End Sub

watersev, how can I remove the formatting, and assign only values to the result() array?
I don't want to carry over the fill and font color, font type etc.


Ans: I found .ClearFormats, problem solved.

sh.Range("a1", sh.Cells(lrow, lcol)).ClearFormats