macro from columns to rows but adding every time a new line

[balan_radu2003]

Hello

I would like to have a code that transforms 2 or more columns in rows.
The special thing here is that if I change the values in the same
columns and run again the macro the new values should apear under the
old lines.

Example:

Column1 - Column2
A --------------- X
B --------------- Y
C --------------- Z

When I run the macro I want that it apears in another place in the
same document same sheet like this:

Line 1 - A B C
Line 2 - X Y Z

If I run again the macro by not changing the data in the columns the
list should update by adding the same thing under the fist 2 lines -
like this:

Line 1 - A B C
Line 2 - X Y Z
Line 3 - A B C
Line 4 - X Y Z

If I change the data in the same Columns like this....

Column1 - Column2
D --------------- G
E --------------- H
F --------------- I

.....and then run again the macro the list should update again by
adding the 2 lines like this:

Line 1 - A B C
Line 2 - X Y Z
Line 3 - A B C
Line 4 - X Y Z
Line 5 - D E F
Line 6 - G H I


I already have some kind of codes that do something similar but I need
them combined somehow:

Fist code:

Sub RoundedRectangle1_Click()
a = 27

Do While Cells(a, 3).Value <> ""
a = a + 1
Loop

Cells(a, 3).Value = Range("C26").Value
End Sub


Second code:

Sub Macro6()
Range("A1:B37").Select
Selection.Copy
Range("G8").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True
Range("G8").Select
End Sub

I would really appreciate your help

Thanks in advance

 

[Per Jessen]

Hi

I think this is what you need:

Sub Macro6()
Range("A1:B37").Copy
If Range("G8").Value = "" Then
Set TargetCell = Range("G8")
Else
Set TargetCell = Range("G8").End(xlDown).Offset(1, 0)
End If
TargetCell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Range("G8").Select
End Sub

Regards,
Per

 

[JLatham]

This solution does the transposition manually, and doesn't require the two
source columns to be adjacent. Only requirement is that things are defined
so that there will always be a blank row above whatever row you decide the
first horizontal copy of the first column ends up in.

Sub RecordColumnEntries()
'these identify the columns
'to be copied
Const firstColumnID = "A"
Const firstColumnRow = 1
Const secondColumnID = "B"

'this identifies where to
'put the first row of the 1st copy
'note that there must be at least
'one empty row between the last
'entry in the columns and this row.
Const firstCopyColumn = "G"
Const firstCopyToRow = 8

'variables used in the moving
Dim nextCopyToRow As Long
Dim sourceBase As Range
Dim destBase As Range
Dim copyOffset As Long

nextCopyToRow = Range(firstCopyColumn & _
Rows.Count).End(xlUp).Row
If nextCopyToRow < firstCopyToRow Then
nextCopyToRow = firstCopyToRow
Else
nextCopyToRow = nextCopyToRow + 1
End If

Set sourceBase = Range(firstColumnID & _
firstColumnRow)
Set destBase = Range(firstCopyColumn & _
nextCopyToRow)
Do While Not _
IsEmpty(sourceBase.Offset(copyOffset, 0))
destBase.Offset(0, copyOffset) = _
sourceBase.Offset(copyOffset, 0)
copyOffset = copyOffset + 1
Loop

Set destBase = destBase.Offset(1, 0)
Set sourceBase = Range(secondColumnID & _
firstColumnRow)
copyOffset = 0
Do While Not _
IsEmpty(sourceBase.Offset(copyOffset, 0))
destBase.Offset(0, copyOffset) = _
sourceBase.Offset(copyOffset, 0)
copyOffset = copyOffset + 1
Loop
Set sourceBase = Nothing
Set destBase = Nothing
End Sub