Macro to Transpose Rows to Columns

[drew1230]

Hey all,

I un-versed in VBA or any type of coding, for that matter, but it looks like formulas won't for what I'm attempting to do. I'm trying to transpose a variable number of cells in a row into columns right beneath the first column. I've already pre-inserted the required number of rows beneath each of the rows I'm trying to transpose.
I'm actually working with columns O to W (8 columns total)

I'm trying to get from...

a	b	c
1	2
aa	bb	cc	dd

<tbody>
</tbody>

to...

a	b	c
b
c
1	2
2
aa	bb	cc	dd
bb
cc
dd

<tbody>
</tbody>

Gotta do this for about 5,000 rows so any help would be appreciated! I can't imagine how many days this would take to finish manually.

-Drew

 

[drew1230]

drew1230,

Can we see what your actual raw data worksheet looks like?

And, can we see what the results (manually formatted by you) should look like?

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com

Sure, here are the first 25 rows of the spreadsheet (with some data changed).

from: https://www.dropbox.com/s/3qegk2wlri3bm12/sample.xlsx?dl=0

to: https://www.dropbox.com/s/q1b3onzdks3yuyc/sampleResult.xlsx?dl=0

 

[hiker95]

drew1230,

Try the following:

Sub ReorganizeData_V2()
' hiker95, 12/13/2017, ME935668
Application.ScreenUpdating = False
Dim a As Variant, r As Long, c As Long, cc As Long, lr As Long, lc As Long, n As Long
Dim o As Variant, j As Long
With ActiveSheet
  lr = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(2, 1), .Cells(lr, lc))
  n = Application.CountA(.Range(.Cells(2, 4), .Cells(lr, lc))) + lr
  ReDim o(1 To n, 1 To lc)
  On Error GoTo FinishUp
  For r = 2 To lr
    j = j + 1
    For c = 1 To lc
      o(j, c) = a(r, c)
    Next c
    For cc = 4 To lc
      If Not a(r, cc) = vbEmpty Then
        j = j + 1: o(j, 3) = a(r, cc)
      End If
    Next cc
  Next r
FinishUp:
  .Range(.Cells(2, 1), .Cells(lr, lc)).ClearContents
  .Cells(2, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub