Need a macro to move data from column into rows

[Guest]

Thank you in advance for reading my call for help

I have a download of data, all in column A, that I need a macro to move into rows. Example

Target Data

Column

De
2
Rank
Capacity 19

Sollo
5
Capacity 2

Outcome

ColumnA ColumnB ColumnC ..... et
Det 29 Rank 0 Capacity19
Sollos 50 Capacity25

The data block occupies over 2000 rows, all in column A. The data base listed is parsed by 4 blank rows before the next data base item begins, such as Det..(info related to Det) then 4 blank rows then Sollos..(info related to Sollos) then 4 blank rows and so on. Also the data base blocks are not regular as Det has three informational data bits while Sollos only has two. To simplify things a bit, the Outcome does not need to delete the blank rows that would result from moving data base info into rows, so it can be as Det... info reated to Det, bunch of blank rows then on to Sollos and related data, then blank rows and so on

Your help is most kindly appreciated

Flos

 

[cucchiaino]

I have a download of data, all in column A, that I need a macro to move into rows. Example:

Target Data:

Column A

Det
29
Rank 0
Capacity 199

Sollos
50
Capacity 25

Outcome:

ColumnA ColumnB ColumnC ..... etc
Det 29 Rank 0 Capacity199
Sollos 50 Capacity25

The data block occupies over 2000 rows, all in column A. The data base

listed is parsed by 4 blank rows before the next data base item begins


Try this:

Sub radd()
Dim r As Long, u As Long
Dim k As Long, c As Integer

k = 1
u = Range("A65000").End(xlUp).Row + 1
r = 1
While r < u
While Cells(r, 1) = ""
r = r + 1
Wend
k = k + 1
c = 3
Cells(k, c) = Cells(r, 1)
r = r + 1
While Cells(r, 1) <> ""
c = c + 1
Cells(k, c) = Cells(r, 1)
r = r + 1
Wend
Wend

End Sub

 

[Cecilkumara Fernando]

floss,

Sub Macro9()

LastRow = Range("A" & Rows.Count).End(xlUp).row

For j = 2 To LastRow

If Not IsEmpty(Range("A" & j)) = True Then
With Range(Range("A" & j), Range("A" & j).End(xlDown))
..Copy
Range("B" & j).PasteSpecial xlPasteAll, , , True
..Clear
End With
Application.CutCopyMode = False
End If

Next j

End Sub

Cecil

Thank you in advance for reading my call for help.

I have a download of data, all in column A, that I need a macro to move into rows. Example:

Target Data:

Column A

Det
29
Rank 0
Capacity 199

Sollos
50
Capacity 25

Outcome:

ColumnA ColumnB ColumnC ..... etc
Det 29 Rank 0 Capacity199
Sollos 50 Capacity25

The data block occupies over 2000 rows, all in column A. The data base

listed is parsed by 4 blank rows before the next data base item begins, such
as Det..(info related to Det) then 4 blank rows then Sollos..(info related
to Sollos) then 4 blank rows and so on. Also the data base blocks are not
regular as Det has three informational data bits while Sollos only has two.
To simplify things a bit, the Outcome does not need to delete the blank rows
that would result from moving data base info into rows, so it can be as
Det... info reated to Det, bunch of blank rows then on to Sollos and related
data, then blank rows and so on.

 

[John]

I see another solution was posted but I worked this up.

John

Sub coltorows()
'
' coltorows Macro
'
Sheets("input").Select
Dim lastrow As Integer
Dim firstrow As Integer
Dim itemrows As Integer
Dim item(1000, 10) As Variant
Dim k As Integer
'
'Allow up to 3000 rows of data in Column A
Cells(1, 1).Offset.End(xlDown).Select
firstrow = ActiveCell.Row
Cells(3000 + firstrow, 1).Offset.End(xlUp).Select
lastrow = ActiveCell.Row
'
' break data up into k items,
' each with up to 4 lines
'
k = 1
'
i = firstrow
newitem:
'
'Count the number of rows of data for this item
'
itemrows = -(Cells(i, 1).Row - _
Cells(i, 1).Offset.End(xlDown).Row) + 1
'
For j = 1 To itemrows
item(k, j) = Cells(i, 1).Text
If i = lastrow Then GoTo alldone
i = i + 1
Next j
'Done with item, increment to next item (4 rows down)
k = k + 1
i = i + 4
If i > lastrow Then GoTo alldone
GoTo newitem
alldone:
Cells(1, 1).Select
'
' Put data onto new sheet with each item in a new column
Sheets("output").Select
For i = 1 To k
For j = 1 To 4
Cells(j + 3, i).Select
Cells(j + 3, i).Value = item(i, j)
Next j
Next i
Range(Cells(4, 1), Cells(8, k)).Columns.AutoFit
Cells(3, 1).Select
End Sub

-----Original Message-----
Thank you in advance for reading my call for help.

I have a download of data, all in column A, that I need a

macro to move into rows. Example:

Target Data:

Column A

Det
29
Rank 0
Capacity 199

Sollos
50
Capacity 25

Outcome:

ColumnA ColumnB ColumnC ..... etc
Det 29 Rank 0 Capacity199
Sollos 50 Capacity25

The data block occupies over 2000 rows, all in column A.

The data base listed is parsed by 4 blank rows before the
next data base item begins, such as Det..(info related to
Det) then 4 blank rows then Sollos..(info related to
Sollos) then 4 blank rows and so on. Also the data base
blocks are not regular as Det has three informational data
bits while Sollos only has two. To simplify things a bit,
the Outcome does not need to delete the blank rows that
would result from moving data base info into rows, so it
can be as Det... info reated to Det, bunch of blank rows
then on to Sollos and related data, then blank rows and so
on.

 

[cucchiaino]

Plus version


Sub radd2()
Dim r As Long, u As Long, a As Integer
Dim k As Long, c As Integer, x As Integer
Dim nome As String, indice As String
Dim v As Long, d, uc As Integer

uc = 4
k = 1
u = Range("A65000").End(xlUp).Row + 1
r = 1
While r < u
While Cells(r, 1) = ""
r = r + 1
Wend
k = k + 1
c = 3
Cells(k, 3) = Cells(r, 1)
r = r + 1
Cells(k, 4) = Cells(r, 1)
r = r + 1
While Cells(r, 1) <> ""
nome = ""
indice = ""
For x = 1 To Len(Cells(r, 1))
a = Asc(Mid(Cells(r, 1), x, 1))
If a > 47 And a < 58 Then
indice = indice & Chr(a)
Else
nome = nome & Chr(a)
End If
Next x
nome = Trim(nome)
v = Val(indice)
d = Application.Match(nome, Range("1:1"), 0)
If IsError(d) Then
uc = uc + 1
d = uc
Cells(1, d) = nome
End If

Cells(k, d) = v
r = r + 1
Wend
Wend

End Sub



( )--- cucchiaino