macro to copy and transpose every seventh row and past in new sheet.

Question

I have surveys being done for my agents the system gives me a report in XML format. When I get the same changed to Excel I get the surveys in the below mentioned format

Survey number
Agent Name
Rating 1
Rating 2
Rating 3 
Rating 4 
Rating 5
Comments

With this format I have around 700 surveys every day and I need to get the same transposed to the below mentioned format

Survey number/Agent Name/Rating 1/Rating 2/Rating 3/Rating 4/Rating 5/Comments

The problem is the macro goes on and on and the file becomes heavy.

Can anyone help as to how a macro could detect the next survey and automatically copy the data from one sheet and then transpose the same on the next sheet so as to fall right below the earlier line. I do not have much of knowledge in VB.

Answer 1

The following source should do what you want.

It uses the first sheet as source and the second sheet as target.

First search for the first empty cell in the first column of sheet 2.

Then loop over all lines in sheet 1 and copy the data, until we find an empty Survey Number. Original data is not deleted, uncomment one line to make that happen (see source).

Sub transpose()
    Dim sourceRow, targetRow, targetColumn As Integer

    ' find first empty row in target sheet
    targetRow = 1
    While (Sheets(2).Cells(targetRow, 1) <> "")
        targetRow = targetRow + 1
    Wend

    sourceRow = 1
    While (Sheets(1).Cells(sourceRow, 1) <> "")
        For targetColumn = 1 To 8
            ' copy
            Sheets(2).Cells(targetRow, targetColumn) = Sheets(1).Cells(sourceRow, 1)
            ' delete original row (uncomment if required)
            ' Sheets(1).Cells(sourceRow, 1) = ""
            sourceRow = sourceRow + 1
        Next targetColumn
        targetRow = targetRow + 1
    Wend
End Sub

Answer 2

Hi Mr Lang, Thank you for a prompt reply I tried the same works good. The XML data has the first colum with the titles in eight rows, then in column B is the data and the surveys I mentioned are around 700 each day and all in the same column without any gaps (unless the survey is half taken) on each row. The code provided was wonderful but would work onlyfor column A and does not function for B. could you guide me on the same please....

The transpose work perfect and in place and just does a brisk job of colating the date one below the other as reqired as well.

thanks once again for a prompt reply.............

Answer 3

Here's another way with just a single loop

Public Sub TransposeData()
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long

    Application.ScreenUpdating = False
    With Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 1 To LastRow Step 8

            .Cells(i, "A").Resize(8).Copy
            NextRow = NextRow + 1
            .Cells(NextRow, "B").PasteSpecial Paste:=xlPasteAll, transpose:=True
        Next i

        .Rows(NextRow + 1).Resize(LastRow - NextRow).Delete
        .Columns(1).Delete
    End With

    Application.ScreenUpdating = True
End Sub