transpose data

[Hilvert Scheper]

Hi There,
I would really appreciate some help on the next subject:
How do I transpose This:
1
1
2
2
3
3

To:
1 1
2 2
3 3

This is a (Combined?) Transpose of 1 Column into Rows, where the data
decides how many Columns I need....

Many Thanks in advance!!!

 

[Mike H]

Hi,

If I understand your requirements correctly try this. Because it deletes
data try on a test workbook first. Right click the sheet tab, view code and
paste this in and run it.

Sub transpose()
Dim deleterange As Range
lastrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For x = 2 To lastrow Step 2
Cells(x, 1).Offset(-1, 1).Value = Cells(x, 1).Value
If deleterange Is Nothing Then
Set deleterange = Cells(x, 1).Resize(, 2)
Else
Set deleterange = Union(deleterange, Cells(x, 1).Resize(, 2))
End If
Next
If Not deleterange Is Nothing Then
deleterange.Delete Shift:=xlUp
End If
End Sub

Mike

 

[Hilvert Scheper]

Thank You Very much indeed Mike,
I think I didn't make myself understood,
I am trying to covert a Column into as many Columns as there is Data:

From:
1
1
2
2
2
3
4
4

To (Multiple Columns):
1 1 (Entry "1" appears 2x)
2 2 2 (Entry "2" appears 3x)
3 (Entry "3" appears 1x)
4 4 (Entry "4" appears 2x)
Etcetera.
Any help is Greatly appreciated.
Many Thanks,
Hilvert

 

[Mike H]

Hi,

A bit more involved bit I think we got there

Sub transpose()
Dim deleterange As Range
lastrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Max = Application.WorksheetFunction.CountIf(Range("A1:A" & lastrow), _
Application.WorksheetFunction.Mode(Range("A1:A" & lastrow)))
col = 1
oset = -1
For x = 2 To lastrow
If Cells(x, 1).Value = Cells(x - 1, 1).Value Then
Cells(x, 1).Offset(oset, col).Value = Cells(x, 1).Value
col = col + 1
oset = oset - 1
If deleterange Is Nothing Then
Set deleterange = Cells(x, 1).Resize(, Max)
Else
Set deleterange = Union(deleterange, Cells(x, 1).Resize(, Max))
End If
Else
col = 1
oset = -1
End If
Next
If Not deleterange Is Nothing Then
deleterange.Delete Shift:=xlUp
End If
End Sub

Mike

 

[Hilvert Scheper]

Many Thanks Mike,
That's a Great help!!!
Hilvert

Hi,

A bit more involved bit I think we got there

Sub transpose()
Dim deleterange As Range
lastrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Max = Application.WorksheetFunction.CountIf(Range("A1:A" & lastrow), _
Application.WorksheetFunction.Mode(Range("A1:A" & lastrow)))
col = 1
oset = -1
For x = 2 To lastrow
If Cells(x, 1).Value = Cells(x - 1, 1).Value Then
Cells(x, 1).Offset(oset, col).Value = Cells(x, 1).Value
col = col + 1
oset = oset - 1
If deleterange Is Nothing Then
Set deleterange = Cells(x, 1).Resize(, Max)
Else
Set deleterange = Union(deleterange, Cells(x, 1).Resize(, Max))
End If
Else
col = 1
oset = -1
End If
Next
If Not deleterange Is Nothing Then
deleterange.Delete Shift:=xlUp
End If
End Sub

Mike

 

[Mike H]

Your welcome and thanks for the feedback

Many Thanks Mike,
That's a Great help!!!
Hilvert