Transpose data in rows separated by common text

[HC1987]

Hi all,

I was wondering if it is possible to transpose data in rows, where each entry is separated by the same line of text. The problem for me is that each data entry contains different amount of rows for each company so cannot simply separate at every e.g. 6th row... Therefore, I need a macro that can recognize the standard line of text as a que for a new transposition. There is no spacing between the rows.

My data looks like this:

company name
address
phone
email
web
STANDARD LINE OF TEXT ("Biotech therapeutics")

I hope someone can help

 

[hiker95]

HC1987,

Here is a macro solution for you to consider.

You can change the raw data worksheet name in the macro.

Sample raw data in column A, in Sheet1, and, the results in column C:

Excel 2007
	A	B	C
1	Company 1		Company 1
2	A		Company 2
3	B
4	C
5	D
6	E
7	www.company1.de
8	in the area of: Biotech Therapeutics & Diagnostics
9	Company 2
10	A2
11	B2
12	C2
13	D2
14	www.company2.de
15	info@company2.de
16	in the area of: Biotech Therapeutics & Diagnostics
17
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ExtractCompanyNames()
' hiker95, 03/30/2015, ME845481
Dim c As Range, nr As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")   ''<-- you can change the raw data sheet name here
  .Columns(3).ClearContents
  nr = 1
  .Cells(1, 1).Copy .Cells(nr, 3)
  For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp).Offset(-1))
    If InStr(c, "Biotech Therapeutics") Then
      nr = nr + 1
      c.Offset(1).Copy .Cells(nr, 3)
    End If
  Next c
  .Columns(3).AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ExtractCompanyNames macro.

 

[HC1987]

hiker95,

This worked like a charm!! Thank you so much!!

Have a great day,
Hans Christian

 

[hiker95]

HC1987,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.