VBA to automatically transpose X rows of data across 10 column into column

[Remi909]

Hey All.

I could really use your help with this one. I have a little VBA knowledge but not enough to do the following:

I have an Excel worksheet with 25 records which assigned to the same person with different piece of information on each row. Currently, this worksheet represents 1,000 people (Making 25000 rows of data)

So what I need to do is come up with a macro that will do the following:

1) Select the first 25 rows of data.
2) Copy/Paste that selection, then TRANSPOSE onto row one, starting at A2 (The first occurrence for each record) and going through A2:J27 (Column A to J have data with 2 blanks between them)
3) Then Delete the rows of data that were transposed into row 1 columns (basically delete 25 rows)
4) Then select the NEXT 25 rows of data, and repeat the whole process, but this time pasting into the row below instead the previous row. New row would start from row A3.
5) This needs to iterate through the whole worksheet until it cycles through all 25000 rows.
6) The end result will be 100 rows of data, with values across columns

Make sense? Ive added a mock up example for reference.

Any help from those more versed in loops would be much appreciated.

Thanks in advance!!

 

[DanteAmor]

Hi and welcome to MrExcel!

Try the following. Your data on sheet1 the results on sheet2.

Sub TransposeRows()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, y As Long
 
  a = Sheets("Sheet1").Range("A2:C" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To 100)
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 2
      b(y, 1) = a(i, 1)
    End If
    j = Split(dic(a(i, 1)), "|")(0)
    k = Split(dic(a(i, 1)), "|")(1)
    b(j, k) = a(i, 2)
    b(j, k + 1) = a(i, 3)
    k = k + 2
    dic(a(i, 1)) = j & "|" & k
  Next
 
  Sheets("Sheet2").Range("A2").Resize(y, k).Value = b
End Sub

Check the results on sheet2, if you still want the results on the same sheet1, change this line:

  Sheets("Sheet2").Range("A2").Resize(y, k).Value = b

by these lines:

  Sheets("Sheet1").Rows("2:" & Rows.Count).ClearContents
  Sheets("Sheet1").Range("A2").Resize(y, k).Value = b

 

[Remi909]

Hello!

Thank you for your respond, much appreciated. Ive tried that code but it doesn't seem to work

 

[Remi909]

Hello!

Thank you for your respond, much appreciated. Ive tried that code but it doesn't seem to work

I am using a MacBook if that helps

 

[DanteAmor]

Ive tried that code but it doesn't seem to work

It would be of great help if you comment:
What does the error message say?
Which line of the macro does it stop at?
What data are you testing?

I have no way to try on a macbook. You should update your profile data, as it says you also have windows.
Wait if someone can help you with a macbook macro.

 

[Remi909]

Corrected.

The error I'm getting is "Run-time error '429': ActiveX component can't create object"

Codes stops at Set dic = CreateObject("Scripting.Dictionary")