Transpose at blank cell

[JMACACK]

Dear All,

I have a column of data that contains addresses as a list. Some of these span 5 lines, some span 6, 7 etc. All are broken by a blank row however.

[TABLE="width: 211"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Company A[/TD]
[/TR]
[TR]
[TD]Smith Road , The Square[/TD]
[/TR]
[TR]
[TD]Smith Street[/TD]
[/TR]
[TR]
[TD]London[/TD]
[/TR]
[TR]
[TD]W1 7EQ[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Company B [/TD]
[/TR]
[TR]
[TD]Unit 11[/TD]
[/TR]
[TR]
[TD]Industrial Park Ltd. [/TD]
[/TR]
[TR]
[TD]Downton Street[/TD]
[/TR]
[TR]
[TD]Washington[/TD]
[/TR]
[TR]
[TD]West Sussex[/TD]
[/TR]
[TR]
[TD]RH20 4YB[/TD]
[/TR]
</tbody>[/TABLE]

I wish to transpose these so that I have a table type format rather than a list;

Company | Add 1 | etc.

Company A | Smith Road, The Square | etc.
Company B | Unit 11 | etc.

Aside from CTRL+C, Transpose for every address (list is about 6,000 rows) any idea how to do this?

All help appreciated!

Cheers.

 

[Kaper]

run simple macro:

Sub test()
Dim inputdata, outdata(), lastrow&, i&, inprow&, outrow&, outcol&, maxcol&
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inputdata = Range("A1").Resize(lastrow).Value
ReDim outdata(1 To lastrow \ 2, 1 To 10)
outrow = 1
For i = 1 To lastrow
  If inputdata(i, 1) = "" Then
    outrow = outrow + 1
    outcol = 0
  Else
    outcol = outcol + 1
    If outcol > 10 Then
      MsgBox "Something went wrong. In row " & i & " there is more than 10 rows of running data", vbCritical
      Rows(i).Select
      Exit Sub
    End If
    outdata(outrow, outcol) = inputdata(i, 1)
    If outcol > maxcol Then maxcol = outcol
  End If
Next i
Range("C1").Resize(outrow, maxcol).Value = outdata
End Sub

If you never did it, press :

Alt+F11 (opens VBE)
Alt+I, M (inserts new module in your file)
copy the code posted above to the module window
Alt+F4 to return to the spreadsheet, (closes VBE)
save file as yourfilename.xlsm (macro enabled format)
Alt+F8 (macro run)
select macro test and press "Run"

your output is in cells C1 and right/down

 

[Rick Rothstein]

Assuming you data starts in cell A1, give this macro a try...

Sub TransposeCompanies()
  Dim Ar As Range
  Application.ScreenUpdating = False
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
    For Each Ar In .SpecialCells(xlConstants).Areas
      Ar(1).Resize(, Ar.Rows.Count) = Application.Transpose(Ar)
    Next
    .Offset(, 1).SpecialCells(xlBlanks).EntireRow.Delete
  End With
  Application.ScreenUpdating = True
End Sub

 

[JMACACK]

Hi Kaper,

Thanks for much for your reply. Alas, I got a couple of errors when trying to run this macro (different ones on different worksheets, strangely!). Anyway, managed to sort it with the macro below.

Thanks.

"

 

[JMACACK]

Hi Rick,

Macro worked great and all data appears as requested! Any suggestions of good resources to get more familiar with the VBA / Macro side of Excel?

I feel I have kind of gone as far as I can without understanding this side better.

Regards

 

[Kaper]

Hi,

Well, there are numerous books and online courses.
It's not that easy to say which one will suit you best.
I probably personaly got most from being active on such forums like this one (I'm not really active here, because I'm missing opportunity to post attachments) and excelforum.com or excelforum.pl (in Polish).

There is also a lot of good (and lot of bad too) tutorials on youtube and other video-sites.

Can't really name best one.