Transfer Date Loop

[Mishelley]

In my first worksheet, I have columns of data that I need transferred into
the second worksheet as rows (records) of data. I need to do this beginning
with Column B until there is a blank column. I am using a macro. How can I
automate this event so that only columns with data are transferred to the
second sheet?

Thank you,
Mishelley

 

[Charlie]

Hi,

Try this:

Sub Macro1()
Dim x As Integer
Dim y As Integer

x = 2 'First row to copy data

Sheets("ColData").Select

y = 1

Do While Len(Trim(Sheets("ColData").Cells(1, y))) > 1 'Go throug
column until blank in row 1

Sheets("ColData").Select
Sheets("ColData").Range(Cells(1, y), Cells(100, y)).Select
Selection.Copy

Sheets("RowData").Select
Sheets("RowData").Cells(x, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone
SkipBlanks:= _
False, Transpose:=True

x = x + 1 'Next row
y = y + 1
Loop
End Sub

Charlie
www.openerconsulting.com

 

[Mishelley]

Thank you for your help, Charlie. When I copy/paste your code and try to run
it, I am getting a syntax error on the following lines:

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True

Can you help?

Thanks,
Mishelley

 

[Charlie]

Hi,

Try this line instead and put it all on one line:
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone
SkipBlanks:=False, Transpose:=True

Here:

Code
-------------------
Sub Macro1()
Dim x As Integer
Dim y As Integer

x = 2 'First row to copy data

Sheets("ColData").Select

y = 2

Do While Len(Trim(Sheets("ColData").Cells(1, y))) > 0 'Go through column until blank in row 1

Sheets("ColData").Select
Sheets("ColData").Range(Cells(1, y), Cells(100, y)).Select
Selection.Copy

Sheets("RowData").Select
Sheets("RowData").Cells(x, 1).Select

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

x = x + 1 'Next row
y = y + 1
Loop
End Sub


-------------------


Charlie
'Opener Consulting Home' (http://www.openerconsulting.com)

Thank you for your help, Charlie. When I copy/paste your code and tr
to run
it, I am getting a syntax error on the following lines:

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=True

Can you help?

Thanks,
Mishelley

 

[Mishelley]

Hi Charlie,

When I run this code, I get a Run-Time error '9':
Subscript out of range

When I go into the code, this line is highlighted in yellow:

Sheets("ColData").Select

Sorry to be a bother.

 

[Charlie]

Hi,


Try this one:

Code
-------------------
Sub Macro1()
Dim x As Integer
Dim y As Integer

x = 2 'First row to copy data

Sheets("ColData").Activate

y = 2

Do While Len(Trim(Sheets("ColData").Cells(1, y))) > 0 'Go through column until blank in row 1

Sheets("ColData").Select
Sheets("ColData").Range(Sheets("ColData").Cells(1, y), Sheets("ColData").Cells(100, y)).Select
Selection.Copy

Sheets("RowData").Select
Sheets("RowData").Cells(x, 1).Select

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

x = x + 1 'Next row
y = y + 1
Loop

Application.CutCopyMode = False
End Su

 

[Mishelley]

Hi,

Same error, but now with this line.

Sheets("ColData").Activate

 

[Charlie]

Hi,

Same error, but now with this line.

Sheets("ColData").Activate

Sorry, I edited the post, I did some modification but you probably
got the old version:

Try this one:
And replace The "Name of the sheet..." by the name of the sheet on your
workbook (Line 6-7 of the code)

Code:
--------------------
Dim x As Integer
Dim y As Integer
Dim SColData As String
Dim SRowData As String

SColData = "Name of the sheet with column data"
SRowData = "Name of the sheet with row data"

x = 2 'First row to copy data

Sheets(SColData).Activate

y = 2

Do While Len(Trim(Sheets(SColData).Cells(1, y))) > 0 'Go through column until blank in row 1

Sheets(SColData).Select
Sheets(SColData).Range(Sheets(SColData).Cells(1, y), Sheets(SColData).Cells(100, y)).Select
Selection.Copy

Sheets(SRowData).Select
Sheets(SRowData).Cells(x, 1).Select

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

x = x + 1 'Next row
y = y + 1

Loop

Application.CutCopyMode = False
End Sub --------------------

Charlie
'Opener Consulting Home' (http://www.openerconsulting.com)