Move data from rows to columns in Excel

[Pich]

Hi!

I have an Excel file in which all my data is in 1 column but on a lot
of rows. I want to restructure it to more columns instead. Like this
example:


NOW I HAVE:
Field 1A Header1
Field 2A Data1
Field 3A Header2
Field 4A Data2
Field 5A Header3
Field 6A Data3

I WANT IT LIKE THIS:
Field 1A Header1
Field 2A Data1
Field 1B Header2
Field 2B Data2
Field 1C Header3
Field 2C Data3


Of course I have a lot of more data under each header, but it is number
of data rows are ambigous.

Is that possible by using some sort of script or macro?

Regards

Pich

 

[Toppers]

Hi,
How do identify a header versus data row as a assume the number of
data rows per header is different?

 

[Pich]

The header does not have a specific identifier, only its name. Their are
a couple of repeating headers with a various number of data rows.
Example:

Header1
Data1
Data2
Data3

Header2
Data1
Data2

Header3
Data1
Data2
Data3
Data4
Data5
Data6

Header1
Data1

Header2
Data1
Data2
Data3
Data4

Header3
Data1
Data2
Data3

and so on....

 

[Toppers]

Hi,
Try this as a starter. It works by assuming the data is always
numeric and the header is not - which I guess is probably wrong so you will
need to change the "loop until ..." test to determine the header. I still
wasn't sure from your reply how I would identify the header.

This code also assumes there are no blank rows between sets of data; again
if this isd not true, the logic will need to be changed.

If this doesn't work, send me a sample of your data.
([email protected])

HTH

Sub Rows2Columns()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim outrng As Range

Set ws1 = Worksheets("Sheet1") ' <==== change to your tab name (input)
Set ws2 = Worksheets("Sheet2") ' <==== Change to your tab name (output)
Set outrng = ws2.Range("a1")

With ws1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
sr = 1
r = 2
Do While r < lastrow
Do
r = r + 1
' Tests for header being non-numeric ==> change to suit your data
' i.e. how do we know this a header row?
' and terminates on last cell being blank i.e. no embedded blanks in
list
Loop Until Not IsNumeric(.Cells(r, 1)) Or .Cells(r, 1) = ""

.Cells(sr, 1).Resize(r - sr, 1).Copy outrng
sr = r
r = r + 1
Set outrng = outrng.Offset(0, 1)
Loop

End With

End Sub