Transpose data into a single cloumn

[davidshe]

Hi everyone

I have just started learning VBA and a friend designed the followin
macro.
The macro takes information from Cell A2 to F2 and creates a new recor
in a single column. That is the is transposed from horizontal acros
columns to a single column, with line break at each record.

This macro works very well.

I would like to learn more about VBA and apply this knowledge using thi
macro.


I would appreciate if a member could add some comments against each lin
so I can understand what the code is doing.

For example is the following selecting the first record down to the las
record in the worksheet.

Range("A2").Select ' start point

Selection.End(xlDown).Select ' bottom record
lastRow = ActiveCell.Row


Thanks Davidshe
Sub UpdateData()

' assuming columns don't go beyond the Z column

Dim lastColumn As String, currentRow As String, destinationArray A
String 'string = text
Dim i As Integer, lastRow, numOfColumns As Integer, destinationStar
As Integer ' Interger = number

Application.ScreenUpdating = False ' opening

Range("A2").Select ' start point

Selection.End(xlDown).Select ' bottom record
lastRow = ActiveCell.Row

Selection.End(xlToRight).Select
numOfColumns = ActiveCell.Column + 1
lastColumn = (Chr(numOfColumns + 64)) ' maximum columns could be
to max etc

' should add in a line here to clear old tranposed data

destinationStart = lastRow

For i = 2 To lastRow
currentRow = "A" & i & ":" & lastColumn & i
destinationArray = "A" & destinationStart + 5 & ":A"
destinationStart + 3 + numOfColumns
Range(destinationArray).FormulaArray = "=transpose("
currentRow & ")"
destinationStart = destinationStart + numOfColumns
Next i

Application.ScreenUpdating = True 'closing

End Su

 

[Claus Busch]

Hi David,

Am Sun, 31 Mar 2013 09:34:56 +0000 schrieb davidshe:

I have just started learning VBA and a friend designed the following
macro.
The macro takes information from Cell A2 to F2 and creates a new record
in a single column. That is the is transposed from horizontal across
columns to a single column, with line break at each record.

[Code snippet]

Select, selection and Activate is not necessary if your referencies are
explicit. I prefer a solution without formulas because formulas will be
new calculated.
My solution copies the range in each row in sheet1 and paste it in
column A of sheet2:

Sub UpdateData()
Dim lastColumn As String
Dim destinationArray As String 'string = text
Dim numOfColumns As Integer
Dim i As Long, lastRow As Long
Dim destinationStart As Long

Application.ScreenUpdating = False
'modify the sheet name
With Sheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
numOfColumns = .Cells(2, .Columns.Count).End(xlToLeft).Column

destinationStart = 1

For i = 2 To lastRow
.Range(.Cells(i, 1), .Cells(i, numOfColumns)).Copy
'modify the sheet name
Sheets("Sheet2").Cells(destinationStart, 1) _
.PasteSpecial xlPasteAll, Transpose:=True
destinationStart = destinationStart + numOfColumns
Next
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub


Regards
Claus Busch

 

[Claus Busch]

Hi David,

Am Sun, 31 Mar 2013 17:04:44 +0200 schrieb Claus Busch:

For i = 2 To lastRow
.Range(.Cells(i, 1), .Cells(i, numOfColumns)).Copy
'modify the sheet name
Sheets("Sheet2").Cells(destinationStart, 1) _
.PasteSpecial xlPasteAll, Transpose:=True
destinationStart = destinationStart + numOfColumns
Next

if the numOfColumns differs from row to row you have to calculate it in
the For-Next-statement:

For i = 2 To lastRow
numOfColumns = .Cells(i, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(i, 1), .Cells(i, numOfColumns)).Copy
'modify the sheet name
Sheets("Sheet2").Cells(destinationStart, 1) _
.PasteSpecial xlPasteAll, Transpose:=True
destinationStart = destinationStart + numOfColumns
Next



Regards
Claus Busch

 

[Claus Busch]

Hi David,

Am Sun, 31 Mar 2013 17:04:44 +0200 schrieb Claus Busch:

My solution copies the range in each row in sheet1 and paste it in
column A of sheet2:

but faster is a solution that writes the data in an array and then
transpose back into the sheet:

Option Base 1

Sub UpdateData2()
Dim LRow As Long
Dim LCol As Integer
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim myArr() As Variant
Dim st As Double

st = Timer
With Sheets("Sheet1")
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LRow
LCol = .Cells(i, Columns.Count).End(xlToLeft).Column
n = j
j = j + LCol
ReDim Preserve myArr(j)
k = 1
For m = n + 1 To n + LCol
myArr(m) = .Cells(i, k)
k = k + 1
Next
Next
End With
Sheets("Sheet2").Range("A1").Resize(UBound(myArr)) = _
WorksheetFunction.Transpose(myArr())
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub


Regards
Claus Busch

 

[GS]

Does Row1 contain headers? If so, why aren't you transposing them in
Col1?

Can each row go in the next Col, or do they need to be stacked for some
reason?

This would give the following layout...

H R R
e o o
a w w
d 2 3
i D D
n a a
g t t
s a a

...and so forth across the sheet.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[GS]

No point duplicating what Claus offers, so I went with what I proposed
so you have an alternative...

Option Explicit

Sub UpdateData3()
Dim lMaxCols&, lLastRow&, lStartRow&, i&, n& '//as Long
Dim vDataIn, vDataOut() '//as Variant

'Get the position of the last row and max columns
'**Assumes source data is contiguous,
'and includes source data header row.**
'<Note>Typically, header rows contain all data fields,
'for the underlying data table,
'whether all fields contain data or not!</Note>
With Range("A1")
lLastRow = .End(xlDown).Row
lMaxCols = .CurrentRegion.Columns.Count
End With
lStartRow = lLastRow + 2 '//offset from source data

'Delete any existing transposed data
Dim l1&, l2& '//as Long
l1 = Cells(lLastRow + 1, 1).Row
l2 = Cells(l1, 1).End(xlDown).Row
Range(l1 & ":" & l2).EntireRow.Delete

'Add some visual space below the source data,
'but ALWAYS have a blank row between source data
'and transposed data. Always insert new rows of
'source data ABOVE the blank row.
Cells(lStartRow, 1).RowHeight = 30 '//edit to suit
ReDim vDataOut(1 To lMaxCols, 1 To 1) '//transposed array

For i = 1 To lLastRow
vDataIn = Range(Cells(i, 1), Cells(i, lMaxCols))
For n = LBound(vDataIn) To UBound(vDataIn, 2)
vDataOut(n, 1) = vDataIn(1, n) '//transpose cols to rows
Next 'n
Cells(lStartRow, i).Resize(lMaxCols, 1) = vDataOut
Next 'i
End Sub

...where I tested (initially) with 5 rows x 5 cols of source data, then
*inserted* 5 more rows of data at Row6, and added 5 more cols to the
right, and tested again with the new data.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[GS]

Oops! See below where copy/paste didn't go properly...

Sub UpdateData3()
Dim lMaxCols&, lLastRow&, lStartRow&, i&, n& '//as Long
Dim vDataIn, vDataOut() '//as Variant

'Get the position of the last row and max columns
'**Assumes source data is contiguous,
'and includes source data header row.**
'<Note>Typically, header rows contain all data fields,
'for the underlying data table,
'whether all fields contain data or not!</Note>
With Range("A1")
lLastRow = .End(xlDown).Row
lMaxCols = .CurrentRegion.Columns.Count
End With
lStartRow = lLastRow + 2 '//offset from source data

'Delete any existing transposed data
Dim l1&, l2& '//as Long

l1 = Cells(lLastRow, 1).End(xlDown).Row

l2 = Cells(l1, 1).End(xlDown).Row
Range(l1 & ":" & l2).EntireRow.Delete

'Add some visual space below the source data,
'but ALWAYS have a blank row between source data
'and transposed data. Always insert new rows of
'source data ABOVE the blank row.
Cells(lStartRow, 1).RowHeight = 30 '//edit to suit
ReDim vDataOut(1 To lMaxCols, 1 To 1) '//transposed array

For i = 1 To lLastRow
vDataIn = Range(Cells(i, 1), Cells(i, lMaxCols))
For n = LBound(vDataIn) To UBound(vDataIn, 2)
vDataOut(n, 1) = vDataIn(1, n) '//transpose cols to rows
Next 'n
Cells(lStartRow, i).Resize(lMaxCols, 1) = vDataOut
Next 'i
End Sub

..where I tested (initially) with 5 rows x 5 cols of source data,
then *inserted* 5 more rows of data at Row6, and added 5 more cols to
the right, and tested again with the new data.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion