help with transpose-like macro

  • Thread starter Thread starter irato
  • Start date Start date
I

irato

Im trying to write a vba macro for an excel spreadsheet that will
format cells from this;
A B C D
1 rat z1 z2 z3
2 cat x1 x2 x3
3 bat c1 c2 c3

to something like this

A B
1 rat z1
2 rat z2
3 rat z3
4 cat x1
5 cat x2
6 cat x3
7 bat c1
8 bat c2
9 bat c3

has anyone encounted a macro which does this or something
similar, or if not, has any idea about how to break down the
problem into logcial steps.
 
oh my nicely formatted tables where ruined. if you cant see, they are
supposed to be excel spreadsheets. The first sheet is 4 columns across
and 3 rows down while the second sheet is 2 columns across and 9
sheets down
 
One way:

Assuming the data [below] to be arranged is in Sheet1, A1:D3
A B C D
1 rat z1 z2 z3
2 cat x1 x2 x3
3 bat c1 c2 c3
Click to expand...

Name the range B1:D3 as say: Alpha

In a new sheet say, Sheet2
-------------------------------

Put in A1:

=OFFSET(Sheet1!$A$1,MATCH(B1,INDIRECT(CHOOSE(MOD(ROW()-1,3)+1,"Sheet1!B:B","
Sheet1!C:C","Sheet1!D:D")),0)-1,0)

Put in B1:

=OFFSET(Alpha,INT((ROW()-1)/COLUMNS(Alpha)),MOD(ROW()-1,COLUMNS(Alpha)),1,1)

Select A1:B1, and copy down to B9
 
Hi
Try this, entering the address of the range of cells containing your
data to be rearrange as 'input range' anf the furst cell of the range
to transpose to as output_range:


Sub arrange_data()
input_range = Range("a1:d3").Address 'range containing data to
transpose
output_range = Range("a6").Address 'address of first cell for
transposed data
input_cols = Range(input_range).Columns.Count
input_rows = Range(input_range).Rows.Count

off_n = 0


For rn = 1 To input_rows
For cn = 2 To input_cols
txt = Range(input_range).Columns(1).Rows(rn).Value & " " &
Range(input_range).Columns(cn).Rows(rn).Value
Range(output_range).Offset(off_n, 0).Value = txt
off_n = off_n + 1

Next
Next

End Sub
 
Nicky > said:
txt = Range(input_range).Columns(1).Rows(rn).Value & " " &
Range(input_range).Columns(cn).Rows(rn).Value
Range(output_range).Offset(off_n, 0).Value = txt
Click to expand...

Perhaps just a slight amendment for the part above
to output into 2 cols, instead of 1 col?:

txt1 = Range(input_range).Columns(1).Rows(rn).Value
txt2 = Range(input_range).Columns(cn).Rows(rn).Value

With Range(output_range)
.Offset(off_n, 0).Value = txt1
.Offset(off_n, 1).Value = txt2
End With
 
irato

Sub colrows()

Dim SrcRg As Range
Dim DestCell1 As Range
Dim RowCounter As Long, ColOffset As Integer
Dim CurrCell As Range
Application.ScreenUpdating = False
Set SrcRg = Selection.Columns(1)
Sheets.Add
Set DestCell1 = ActiveCell
For Each CurrCell In SrcRg.Cells
ColOffset = 1
While CurrCell.Offset(0, ColOffset).Value <> ""
DestCell1.Offset(RowCounter).Value = CurrCell.Value
DestCell1.Offset(RowCounter, 1).Value = CurrCell.Offset(0, _
ColOffset).Value
RowCounter = RowCounter + 1
ColOffset = ColOffset + 1
Wend
Next
End Sub

Gord Dibben Excel MVP
 
Thank you all for your help. I really should apologise because looking
back now i see that i excluded some important bits of info. I should
have said that the rows are of varying length, not fixed as it looks
from my sheet drawing.
The other detail is that the function needs to be transpose the rows at
any position in a worksheet, not just at the A:1 position.
I wrote a macro after work which hopefully does the trick , if anyone
wants to have a good laugh here it is, (this is my first macro, im
just learning as i go)


Sub Macro1()
'
' Macro1 Macro
' Macro recorded 18/02/2004 by Stu
'

'

Dim count As Integer
count = 0

Dim col As Integer

col = ActiveCell.Column


Do While IsEmpty(ActiveCell.Offset(0, 1)) = False
count = count + 1
ActiveCell.Offset(0, 1).Select
Loop

ActiveCell.Offset(0, -count).Select

Dim temp As Integer
temp = count

Do While temp > 0
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
temp = temp - 1
Loop
ActiveCell.Offset(-count, col).Range("A1").Select

Dim i As Integer
Dim j As Integer
i = 1
j = -1

temp = count
Do While temp > 0

Selection.Cut Destination:=ActiveCell.Offset(i, j).Range("A1")
ActiveCell.Offset(0, 1).Range("A1").Select
i = i + 1
j = j - 1



temp = temp - 1
Loop
temp = count + 1
ActiveCell.Offset(temp, -temp).Range("A1").Select


End Sub
 
Maybe try the sub colrows1 below?
[Slightly amended the sub given by MVP Gord Dibben]

Steps to run are given in the comments
[essentially select input range > run sub > specify topleft cell of output
range]

Sub colrows1()
'Amended [Original sub by GordDibben_.programming_19Feb2004]

'Steps:
'Select the input range (e.g.: select B7:E9) and then run the sub
'Enter the top left cell for the output range when prompted, e.g.: B11
'Sub will output to a 2 column range with the top left cell as entered

Dim SrcRg As Range
Dim DestCell1 As Range
Dim RowCounter As Long, ColOffset As Integer
Dim CurrCell As Range
Application.ScreenUpdating = False
Set SrcRg = Selection.Columns(1)
Set DestCell1 = Range(InputBox("Enter topleft cell" _
& vbCrLf & "for the output range"))
For Each CurrCell In SrcRg.Cells
ColOffset = 1
While CurrCell.Offset(0, ColOffset).Value <> ""
DestCell1.Offset(RowCounter).Value = CurrCell.Value
DestCell1.Offset(RowCounter, 1).Value = CurrCell.Offset(0, _
ColOffset).Value
RowCounter = RowCounter + 1
ColOffset = ColOffset + 1
Wend
Next
End Sub
 
Back
Top